diff --git a/implementations/racket/preserves/preserves-schema/main.rkt b/implementations/racket/preserves/preserves-schema/main.rkt
new file mode 100644
index 0000000..a695663
--- /dev/null
+++ b/implementations/racket/preserves/preserves-schema/main.rkt
@@ -0,0 +1,69 @@
+#lang racket/base
+
+(provide schema->module-stx)
+
+(require preserves)
+(require racket/match)
+(require (only-in racket/string string-join))
+(require (only-in racket/format ~a))
+
+(require "type.rkt")
+(require "parser.rkt")
+(require "unparser.rkt")
+
+(define (struct-stx name-pieces field-names)
+  `(struct ,(string->symbol (string-join (map ~a name-pieces) "-")) ,field-names #:prefab))
+
+(define (schema-definition-table schema)
+  (match schema
+    [(record 'schema (list (hash-table ('definitions definition-table) (_ _) ...)))
+     definition-table]))
+
+(define (struct-defs schema)
+  (reverse (for/fold [(acc '())]
+                     [((name def) (in-hash (schema-definition-table schema)))]
+             (match (definition-ty def)
+               [(ty-union variants)
+                (for/fold [(acc acc)]
+                          [(variant (in-list variants))]
+                  (match-define (list variant-name variant-ty) variant)
+                  (match variant-ty
+                    [(ty-record fields)
+                     (cons (struct-stx (list name variant-name) (map car fields)) acc)]
+                    [(ty-unit)
+                     (cons (struct-stx (list name variant-name) '()) acc)]
+                    [_
+                     (cons (struct-stx (list name variant-name) '(value)) acc)]))]
+               [(ty-record fields)
+                (cons (struct-stx (list name) (map car fields)) acc)]
+               [_
+                acc]))))
+
+(define (parser-defs schema)
+  (for/list [((name def) (in-hash (schema-definition-table schema)))]
+    (definition-parser name def)))
+
+(define (unparser-defs schema)
+  (for/list [((name def) (in-hash (schema-definition-table schema)))]
+    (definition-unparser name def)))
+
+(define (schema->module-stx name schema)
+  `(module ,name racket/base
+     (provide (all-defined-out))
+     (require preserves)
+     (require preserves-schema/support)
+     (require racket/match)
+     (require racket/set)
+     (require racket/dict)
+     ,@(struct-defs schema)
+     ,@(parser-defs schema)
+     ,@(unparser-defs schema)))
+
+(module+ main
+  (require racket/pretty)
+  (with-output-to-file "gen-schema.rkt" #:exists 'replace
+    (lambda ()
+      (pretty-write
+       (schema->module-stx
+        'gen-schema
+        (with-input-from-file "../../../../schema/schema.bin" read-preserve))))))
diff --git a/implementations/racket/preserves/preserves-schema/parser.rkt b/implementations/racket/preserves/preserves-schema/parser.rkt
new file mode 100644
index 0000000..06e763b
--- /dev/null
+++ b/implementations/racket/preserves/preserves-schema/parser.rkt
@@ -0,0 +1,108 @@
+#lang racket/base
+
+(provide definition-parser)
+
+(require preserves)
+(require racket/match)
+(require (only-in racket/syntax format-symbol))
+
+(require "type.rkt")
+
+(define (definition-parser name def)
+  (define ty (definition-ty def))
+  `(define (,(format-symbol "parse-~a" name) input)
+     ,(match def
+        [(record 'or (list named-alts))
+         `(match input
+            ,@(for/list [(named-alt (in-list named-alts))
+                         (alt-ty (in-list (map cadr (ty-union-variants ty))))]
+                (match-define (list variant-label-str pattern) named-alt)
+                `[,(pattern->match-pattern pattern 'dest)
+                  ,(construct (format-symbol "~a-~a" name variant-label-str) #t alt-ty)])
+            [_ eof])]
+        [(record 'and (list named-pats))
+         `(match input
+            [(and ,@(for/list [(named-pat named-pats)] (pattern->match-pattern named-pat '_)))
+             ,(construct name #f ty)]
+            [_ eof])]
+        [pattern
+         `(match input
+            [,(pattern->match-pattern pattern 'dest)
+             ,(construct name #f ty)]
+            [_ eof])])))
+
+(define (construct name wrap? ty)
+  (match ty
+    [(ty-record fields) `(,name ,@(map escape (map car fields)))]
+    [(ty-unit) (if wrap? `(,name) `(void))]
+    [_ (if wrap? `(,name dest) 'dest)]))
+
+(define (maybe-dest dest-pat-stx pat)
+  (match dest-pat-stx
+    ['_ pat]
+    [_ `(and ,dest-pat-stx ,pat)]))
+
+(define (pattern->match-pattern pattern dest-pat-stx)
+  (match pattern
+    [(record 'named (list n p)) (pattern->match-pattern p (maybe-dest dest-pat-stx (escape n)))]
+    ['any dest-pat-stx]
+    [(record 'atom (list atom-kind))
+     (maybe-dest dest-pat-stx
+                 `(? ,(match atom-kind
+                        ['Boolean 'boolean?]
+                        ['Float 'float?]
+                        ['Double 'flonum?]
+                        ['SignedInteger 'integer?]
+                        ['String 'string?]
+                        ['ByteString 'bytes?]
+                        ['Symbol 'symbol?])))]
+    [(record 'embedded '()) (error 'pattern-parser "Embedded not yet implemented")]
+    [(record 'lit (list v)) (maybe-dest dest-pat-stx (literal->pattern v))]
+    [(record 'ref (list '() name))
+     `(app ,(format-symbol "parse-~a" name) ,(maybe-dest dest-pat-stx `(not (== eof))))]
+    [(record 'ref (list module-path name))
+     (error 'pattern-parser "Ref with non-empty module path not yet implemented")]
+    [(record 'tuple* (list '() (and variable-pat (not (record 'named _)))))
+     `(parse-sequence list?
+                      values
+                      ,(pattern->match-pattern variable-pat 'item)
+                      item
+                      values
+                      ,dest-pat-stx)]
+    [(record 'setof (list pat))
+     `(parse-sequence set?
+                      set->list
+                      ,(pattern->match-pattern pat 'item)
+                      item
+                      list->set
+                      ,dest-pat-stx)]
+    [(record 'dictof (list key-pat value-pat))
+     `(parse-sequence dict?
+                      dict->list
+                      (cons ,(pattern->match-pattern key-pat 'key)
+                            ,(pattern->match-pattern value-pat 'value))
+                      (cons key value)
+                      make-immutable-hash
+                      ,dest-pat-stx)]
+    [(record 'rec (list label-pat fields-pat))
+     (maybe-dest dest-pat-stx `(record ,(pattern->match-pattern label-pat '_)
+                                       ,(pattern->match-pattern fields-pat '_)))]
+    [(record 'tuple (list named-pats))
+     (maybe-dest dest-pat-stx
+                 `(list ,@(map (lambda (p) (pattern->match-pattern p '_)) named-pats)))]
+    [(record 'tuple* (list fixed-named-pats (record 'named (list vname vpat))))
+     (maybe-dest dest-pat-stx
+                 `(list* ,@(map (lambda (p) (pattern->match-pattern p '_)) fixed-named-pats)
+                         (list ,(pattern->match-pattern vpat (escape vname)) ...)))]
+    [(record 'dict (list (hash-table (keys pats) ...)))
+     (maybe-dest dest-pat-stx
+                 `(hash-table ,@(for/list [(key (in-list keys))
+                                           (pat (in-list pats))]
+                                  `(,(literal->pattern key)
+                                    ,(pattern->match-pattern (add-name-if-absent key pat) '_)))
+                              (_ _) ...))]))
+
+(define (literal->pattern v)
+  (if (symbol? v)
+      `',v
+      `(== ',v)))
diff --git a/implementations/racket/preserves/preserves-schema/support.rkt b/implementations/racket/preserves/preserves-schema/support.rkt
new file mode 100644
index 0000000..1d995e9
--- /dev/null
+++ b/implementations/racket/preserves/preserves-schema/support.rkt
@@ -0,0 +1,18 @@
+#lang racket/base
+
+(provide parse-sequence)
+
+(require racket/match)
+
+(define-match-expander parse-sequence
+  (syntax-rules ()
+    [(_ predicate? to-list item-pat item-expr from-list target-pat)
+     (? predicate? (app (lambda (v)
+                          (let loop ((inputs (to-list v)) (acc-rev '()))
+                            (match inputs
+                              ['() (values #t (from-list (reverse acc-rev)))]
+                              [(cons untransformed remainder)
+                               (match untransformed
+                                 [item-pat (loop remainder (cons item-expr acc-rev))]
+                                 [_ (values #f #f)])])))
+                        #t target-pat))]))
diff --git a/implementations/racket/preserves/preserves-schema/type.rkt b/implementations/racket/preserves/preserves-schema/type.rkt
new file mode 100644
index 0000000..6c410b2
--- /dev/null
+++ b/implementations/racket/preserves/preserves-schema/type.rkt
@@ -0,0 +1,90 @@
+#lang racket/base
+
+(provide (struct-out ty-union)
+         (struct-out ty-unit)
+         (struct-out ty-value)
+         (struct-out ty-record)
+         (struct-out ty-array)
+         (struct-out ty-set)
+         (struct-out ty-dictionary)
+
+         definition-ty
+         add-name-if-absent
+         escape)
+
+(require preserves/record)
+(require racket/match)
+(require (only-in racket/syntax format-symbol))
+
+(struct ty-union (variants) #:transparent)
+(struct ty-unit () #:transparent)
+(struct ty-value () #:transparent)
+(struct ty-record (fields) #:transparent)
+(struct ty-array (type) #:transparent)
+(struct ty-set (type) #:transparent)
+(struct ty-dictionary (key-type value-type) #:transparent)
+
+(define (definition-ty d)
+  (match d
+    [(record 'or (list named-alts))
+     (ty-union (map (match-lambda
+                      [(list variant-label-str pattern)
+                       (list (string->symbol variant-label-str) (pattern-ty pattern))])
+                    named-alts))]
+    [(record 'and (list named-pats)) (product-ty named-pats)]
+    [pattern (pattern-ty pattern)]))
+
+(define (product-ty named-pats)
+  (match (gather-fields* named-pats '())
+    ['() (ty-unit)]
+    [fields (ty-record fields)]))
+
+(define (gather-fields* named-pats acc)
+  (foldr gather-fields acc named-pats))
+
+(define (gather-fields named-pat acc)
+  (match named-pat
+    [(record 'named (list n p))
+     (match (pattern-ty p)
+       [(ty-unit) acc]
+       [ty (cons (list n ty) acc)])]
+    [(record 'rec (list label-named-pat fields-named-pat))
+     (gather-fields label-named-pat (gather-fields fields-named-pat acc))]
+    [(record 'tuple (list named-pats)) (gather-fields* named-pats acc)]
+    [(record 'tuple* (list fixed-named-pats variable-named-pat))
+     (gather-fields* fixed-named-pats (gather-fields variable-named-pat acc))]
+    [(record 'dict (list (hash-table (keys pats) ...)))
+     (gather-fields* (map add-name-if-absent keys pats) acc)]
+    [_ acc]))
+
+(define (pattern-ty p)
+  (match p
+    ['any (ty-value)]
+    [(record 'atom (list _atom-kind)) (ty-value)]
+    [(record 'embedded '()) (ty-value)]
+    [(record 'lit (list _value)) (ty-unit)]
+    [(record 'ref (list _module-path _name)) (ty-value)]
+    [(record 'tuple* (list '() (and variable-pat (not (record 'named _)))))
+     (ty-array (pattern-ty variable-pat))]
+    [(record 'setof (list pat)) (ty-set (pattern-ty pat))]
+    [(record 'dictof (list key-pat value-pat))
+     (ty-dictionary (pattern-ty key-pat) (pattern-ty value-pat))]
+    [_ (product-ty (list p))]))
+
+(define (add-name-if-absent k p)
+  (match p
+    [(record 'named _) p]
+    [_ (match (namelike k)
+         [#f p]
+         [s (record 'named (list s p))])]))
+
+(define (namelike v)
+  (match v
+    [(? string? s) (string->symbol s)]
+    [(? symbol? s) s]
+    [(? number? n) (string->symbol (number->string n))]
+    [(? boolean? b) (if b 'true 'false)]
+    [_ #f]))
+
+(define (escape s)
+  (format-symbol "$~a" s))
diff --git a/implementations/racket/preserves/preserves-schema/unparser.rkt b/implementations/racket/preserves/preserves-schema/unparser.rkt
new file mode 100644
index 0000000..83149ce
--- /dev/null
+++ b/implementations/racket/preserves/preserves-schema/unparser.rkt
@@ -0,0 +1,81 @@
+#lang racket/base
+
+(provide definition-unparser)
+
+(require preserves)
+(require racket/match)
+(require (only-in racket/syntax format-symbol))
+(require (only-in racket/list append-map))
+
+(require "type.rkt")
+
+(define (simple-pattern? p)
+  (match p
+    ['any #t]
+    [(record 'atom _) #t]
+    [(record 'embedded _) #t]
+    [(record 'lit _) #t]
+    [(record 'ref _) #t]
+    [_ #f]))
+
+(define (definition-unparser name def)
+  (define ty (definition-ty def))
+  `(define (,(format-symbol "~a->preserves" name) input)
+     ,(match def
+        [(record 'or (list named-alts))
+         `(match input
+            ,@(for/list [(named-alt (in-list named-alts))
+                         (alt-ty (in-list (map cadr (ty-union-variants ty))))]
+                (match-define (list variant-label-str pattern) named-alt)
+                `[,(deconstruct (format-symbol "~a-~a" name variant-label-str) #t alt-ty)
+                  ,(pattern->unparser pattern 'src)]))]
+        [(record 'and (list named-pats))
+         `(match input
+            [,(deconstruct name #f ty)
+             (merge-preserves (lambda (a b) (if (equal? a b) a (error 'merge-preserves "Cannot merge")))
+                              ,@(append-map
+                                 (lambda (named-pat)
+                                   (if (simple-pattern? named-pat)
+                                       '()
+                                       (list (pattern->unparser named-pat 'src))))
+                                 named-pats))])]
+        [pattern
+         `(match input
+            [,(deconstruct name #f ty)
+             ,(pattern->unparser pattern 'src)])])))
+
+(define (deconstruct name wrap? ty)
+  (match ty
+    [(ty-record fields) `(,name ,@(map escape (map car fields)))]
+    [(ty-unit) (if wrap? `(,name) '(? void?))]
+    [_ (if wrap? `(,name src) 'src)]))
+
+(define (pattern->unparser pattern src-stx)
+  (match pattern
+    [(record 'named (list n p)) (pattern->unparser p (escape n))]
+    ['any src-stx]
+    [(record 'atom (list _atom-kind)) src-stx]
+    [(record 'embedded '()) (error 'pattern-parser "Embedded not yet implemented")]
+    [(record 'lit (list v)) `',v]
+    [(record 'ref (list '() name)) `(,(format-symbol "~a->preserves" name) ,src-stx)]
+    [(record 'ref (list module-path name))
+     (error 'pattern-parser "Ref with non-empty module path not yet implemented")]
+    [(record 'tuple* (list '() (and variable-pat (not (record 'named _)))))
+     `(for/list [(item (in-list ,src-stx))] ,(pattern->unparser variable-pat 'item))]
+    [(record 'setof (list pat))
+     `(for/set [(item (in-set ,src-stx))] ,(pattern->unparser pat 'item))]
+    [(record 'dictof (list key-pat value-pat))
+     `(for/hash [((key value) (in-dict ,src-stx))]
+        (values ,(pattern->unparser key-pat 'key)
+                ,(pattern->unparser value-pat 'value)))]
+    [(record 'rec (list label-pat fields-pat))
+     `(record ,(pattern->unparser label-pat src-stx) ,(pattern->unparser fields-pat src-stx))]
+    [(record 'tuple (list named-pats))
+     `(list ,@(for/list [(p (in-list named-pats))] (pattern->unparser p src-stx)))]
+    [(record 'tuple* (list fixed-named-pats (record 'named (list vname vpat))))
+     `(list* ,@(for/list [(p (in-list fixed-named-pats))] (pattern->unparser p src-stx))
+             (for/list [(item (in-list ,(escape vname)))] ,(pattern->unparser vpat 'item)))]
+    [(record 'dict (list (hash-table (keys pats) ...)))
+     `(hash ,@(append-map (lambda (key pat)
+                            (list `',key (pattern->unparser (add-name-if-absent key pat) src-stx)))
+                          keys pats))]))