diff --git a/syndicate/pattern.rkt b/syndicate/pattern.rkt
index 7b0bc60..12152d6 100644
--- a/syndicate/pattern.rkt
+++ b/syndicate/pattern.rkt
@@ -37,7 +37,7 @@
 
 (define-syntax (define-preserves-pattern stx)
   (syntax-case stx ()
-    [(_ (ctor-stx field-stxs ...) pattern-stx bindings-stx)
+    [(_ top-type-name (ctor-stx field-stxs ...) pattern-stx bindings-stx)
      #`(begin (begin-for-syntax
                 (register-preserves-pattern!
                  #'ctor-stx
@@ -50,7 +50,7 @@
                      ['template
                       (syntax-case s ()
                         [(_ field-stxs ...)
-                         (syntax (#,(format-id #'ctor-stx "~a->preserves" (syntax-e #'ctor-stx))
+                         (syntax (#,(format-id #'ctor-stx "~a->preserves" (syntax-e #'top-type-name))
                                   (ctor-stx field-stxs ...)))])]
                      ['bindings
                       (syntax-case s ()
diff --git a/syndicate/schema-compiler.rkt b/syndicate/schema-compiler.rkt
index ce7ba77..0571b0f 100644
--- a/syndicate/schema-compiler.rkt
+++ b/syndicate/schema-compiler.rkt
@@ -70,14 +70,14 @@
                                (if (equal? s discard) `() `(',k ,s)))))))]
         [other (error 'pat-pattern "Unimplemented: ~v" other)]))
 
-    (define (top-pat name p ty k-nonrecord)
+    (define (top-pat top-name name p ty k-nonrecord)
       (let ((fields (match ty
                       [(ty-unit) '()]
                       [(ty-record fields) (map escape (map car fields))]
                       [_ #f])))
         (if (not fields)
             (k-nonrecord)
-            `(define-preserves-pattern (,name ,@fields)
+            `(define-preserves-pattern ,top-name (,name ,@fields)
                (quasisyntax ,(pat-pattern p))
                (append ,@(for/list [(f (in-list fields))]
                            `(analyse-pattern-bindings (syntax ,f))))))))
@@ -87,12 +87,15 @@
        `(begin ,@(for/list [(named-alt (in-list (list* p0 p1 pN)))
                             (alt-ty (in-list (map cadr (ty-union-variants (definition-ty def)))))]
                    (match-define (NamedAlternative variant-label-str pattern) named-alt)
-                   (top-pat (format-symbol "~a-~a" name variant-label-str) pattern alt-ty
-                            (lambda () `(begin)))))]
+                   (define full-name (format-symbol "~a-~a" name variant-label-str))
+                   (top-pat name full-name pattern alt-ty
+                            (lambda () `(define-preserves-pattern ,name (,full-name value)
+                                          (analyse-pattern #'value)
+                                          (analyse-pattern-bindings (syntax value)))))))]
       [(? Definition-and?)
        `(begin)]
       [(Definition-Pattern p)
-       (top-pat name p (definition-ty def) (lambda () `(begin)))]))
+       (top-pat name name p (definition-ty def) (lambda () `(begin)))]))
 
   (define exprs
     `((require (prefix-in :pat: ,ds-path))