diff --git a/collects/stxclass/main.ss b/collects/stxclass/main.ss
index ad37c75457..b8e06462a2 100644
--- a/collects/stxclass/main.ss
+++ b/collects/stxclass/main.ss
@@ -8,11 +8,14 @@
          define-basic-syntax-class*
          pattern
          basic-syntax-class
+         ~and
+         ~or
+         ...*
 
          syntax-parse
          syntax-parser
          with-patterns
-         ...*
+         attribute
 
          current-expression
          current-macro-name
diff --git a/collects/stxclass/private/codegen-data.ss b/collects/stxclass/private/codegen-data.ss
index 8579caf711..77938937f4 100644
--- a/collects/stxclass/private/codegen-data.ss
+++ b/collects/stxclass/private/codegen-data.ss
@@ -10,19 +10,27 @@
 ;;   - 'fail' stxparameterized to (non-escaping!) failure procedure
 (define-struct pk (ps k) #:transparent)
 
-;; An ExtPK is one of
+;; A Group (G) is one of
 ;;   - PK
-;;   - (make-idpks stxclass (listof stx) (listof PK))
-;;   - (make-cpks (listof PK) (listof DatumPKS) (listof LiteralPKS))
-;;       the first field has only pair patterns
-(define-struct idpks (stxclass args idpks))
-(define-struct cpks (pairpks datumpks literalpks))
+;;   - (make-idG stxclass (listof stx) (listof PK))
+;;     where each PK starts with an id pattern of given stxclass/args
+;;   - (make-descrimG (listof DatumSG) (listof LiteralSG) (listof CompountSGs))
+;;     where each DatumSG/LiteralSG/CompoundSG has a different datum/lit/kind
+(define-struct idG (stxclass args idpks) #:transparent)
+(define-struct descrimG (datumSGs literalSGs kindSGs) #:transparent)
 
-;; A DatumPKS is (make-datumpks datum (listof PK))
-(define-struct datumpks (datum pks))
+;; A DatumSG is (make-datumSG datum (listof PK))
+;; where each PK starts with a datum pattern equal to datum
+(define-struct datumSG (datum pks))
+
+;; A LiteralSG is (make-literalSG id (listof PK))
+;; where each PK starts with a literal pattern equal to literal
+(define-struct literalSG (literal pks))
+
+;; A CompoundSG is (make-compoundSG Kind (listof PK))
+;; where each PK starts with a compound pattern of given kind
+(define-struct compoundSG (kind pks))
 
-;; A LiteralPKS is (make-literalpks identifier (listof PK))
-(define-struct literalpks (literal pks))
 
 ;; A FrontierContextExpr (FCE) is one of
 ;;  - (make-fce Id FrontierIndexExpr)
@@ -55,6 +63,11 @@
             (cons (fi:add-index (car (fce-indexes fc)) expr)
                   (cdr (fce-indexes fc)))))
 
+(define (frontier:add-unvector fc)
+  (frontier:add-car fc (fce-stx fc)))
+(define (frontier:add-unbox fc)
+  (frontier:add-car fc (fce-stx fc)))
+
 (define (join-frontiers base ext)
   (make-joined-frontier base ext))
 
@@ -80,6 +93,7 @@
        stx]
       [(struct joined-frontier (base ext))
        #`(let ([inner-failure #,ext])
-           (or (and (failed? inner-failure) (failed-frontier-stx inner-failure))
+           (or (and (failed? inner-failure)
+                    (failed-frontier-stx inner-failure))
                #,(loop base)))]))
   (loop fc))
diff --git a/collects/stxclass/private/codegen.ss b/collects/stxclass/private/codegen.ss
index 4a08c7720b..5bb8d59758 100644
--- a/collects/stxclass/private/codegen.ss
+++ b/collects/stxclass/private/codegen.ss
@@ -33,13 +33,14 @@
                                    "syntax class has no variants"))
                    (parse:pks (list #'x)
                               (list (empty-frontier #'x))
-                              pks
-                              #'fail-rhs))))]
+                              #'fail-rhs
+                              (list #f)
+                              pks))))]
         [(rhs:basic? rhs)
          (rhs:basic-parser rhs)]))
 
 ;; parse:clauses : stx identifier identifier -> stx
-(define (parse:clauses stx var failid)
+(define (parse:clauses stx var phi)
   (define clauses-kw-table
     (list (list '#:literals check-literals-list)))
   (define-values (chunks clauses-stx)
@@ -70,8 +71,9 @@
       (wrong-syntax stx "no variants"))
     (parse:pks (list var)
                (list (empty-frontier var))
-               pks
-               failid)))
+               phi
+               (list #f)
+               pks)))
 
 ;; rhs->pks : RHS (listof SAttr) identifier -> (listof PK)
 (define (rhs->pks rhs relsattrs main-var)
@@ -117,8 +119,9 @@
                  [fail-k enclosing-fail])
              #,(parse:pks (list #'x)
                           (list (done-frontier #'x))
-                          (list (make-pk (list p) inner))
-                          #'fail-k))))]))
+                          #'fail-k
+                          (list #f)
+                          (list (make-pk (list p) inner))))))]))
 
 ;; success-expr : (listof IAttr) (listof SAttr) RemapEnv stx -> stx
 (define (success-expr iattrs relsattrs remap main-var)
@@ -142,47 +145,72 @@
 
 ;; Parsing
 
-;; parse:pks : (listof identifier) (listof FCE) (listof PK) identifier -> stx
+#|
+
+The parsing algorithm is based on the classic backtracking
+algorithm (see Optimizing Pattern Matching for an overview). A PK
+corresponds to a row in the pattern matrix. The failure argument
+corresponds to the static catch continuation.
+
+The FCs (frontier contexts, one per column) are an addition for error
+reporting. They track the matcher's progress into the term. The
+matcher compares failures on backtracking, and reports the "furthest
+along" failure, based on the frontiers.
+
+Conventions:
+  <ParseConfig> =
+    vars : listof identifiers, variables, one per column
+    fcs : listof FCEs, failure contexts, one per column
+    phi : id, failure continuation
+    ds : listof (string/#f), description string
+
+|#
+
+
+;; parse:pks : <ParseConfig> (listof PK) -> stx
 ;; Each PK has a list of |vars| patterns.
 ;; The list of PKs must not be empty.
-(define (parse:pks vars fcs pks failid)
+(define (parse:pks vars fcs phi ds pks)
   (cond [(null? pks)
          (error 'parse:pks "internal error: empty list of rows")]
         [(null? vars)
          ;; Success!
-         (let* ([failvar (car (generate-temporaries #'(fail-k)))]
+         (let* ([failvar (generate-temporary 'fail-k)]
                 [exprs
                  (for/list ([pk pks])
                    #`(with-enclosing-fail #,failvar #,(pk-k pk)))])
            (with-syntax ([failvar failvar]
                          [(expr ...) exprs])
-             #`(try failvar [expr ...] #,failid)))]
+             #`(try failvar [expr ...] #,phi)))]
         [else
-         (let-values ([(vars extpks) (split-pks vars pks)])
-           (let* ([failvar (car (generate-temporaries #'(fail-k)))]
+         (let-values ([(vars groups) (split-pks vars pks)])
+           (let* ([failvar (generate-temporary 'fail-k)]
                   [exprs
-                   (for/list ([extpk extpks])
-                     (parse:extpk vars fcs extpk failvar))])
+                   (for/list ([group groups])
+                     (parse:group vars fcs failvar ds group))])
              (with-syntax ([failvar failvar]
                            [(expr ...) exprs])
-               #`(try failvar [expr ...] #,failid))))]))
+               #`(try failvar [expr ...] #,phi))))]))
 
 
-;; parse:extpk : (listof identifier) (listof FCE) ExtPK identifier -> stx
+;; parse:group : <ParseConfig> Group -> stx
 ;; Pre: vars is not empty
-(define (parse:extpk vars fcs extpk failid)
-  (match extpk
-    [(struct idpks (stxclass args pks))
+(define (parse:group vars fcs phi ds group)
+  (match group
+    [(struct idG (stxclass args pks))
      (if stxclass
-         (parse:pk:id/stxclass vars fcs failid stxclass args pks)
-         (parse:pk:id/any  vars fcs failid args pks))]
-    [(struct cpks (pairpks datumpkss literalpkss))
-     (parse:pk:c vars fcs failid pairpks datumpkss literalpkss)]
+         (parse:group:id/stxclass vars fcs phi ds stxclass args pks)
+         (parse:group:id/any vars fcs phi ds args pks))]
+    [(struct descrimG (datumSGs literalSGs kindSGs))
+     (parse:group:descrim vars fcs phi ds datumSGs literalSGs kindSGs)]
+    [(struct pk ((cons (? pat:and? and-pattern) rest-patterns) k))
+     (parse:group:and vars fcs phi ds and-pattern rest-patterns k)]
     [(struct pk ((cons (? pat:gseq? gseq-pattern) rest-patterns) k))
-     (parse:pk:gseq vars fcs failid gseq-pattern rest-patterns k)]))
+     (parse:group:gseq vars fcs phi ds gseq-pattern rest-patterns k)]))
 
-;; parse:pk:id/stxclass : (listof id) (listof FCE) id SC stx (listof pk) -> stx
-(define (parse:pk:id/stxclass vars fcs failid stxclass args pks)
+;; parse:group:id/stxclass : <ParseConfig> SC stx (listof pk)
+;;                        -> stx
+(define (parse:group:id/stxclass vars fcs phi ds stxclass args pks)
   (with-syntax ([var0 (car vars)]
                 [(arg ...) args]
                 [(arg-var ...) (generate-temporaries args)]
@@ -191,77 +219,108 @@
     #`(let ([arg-var arg] ...)
         (let ([result (parser var0 arg-var ...)])
           (if (ok? result)
-              #,(parse:pks (cdr vars) (cdr fcs) (shift-pks:id pks #'result) failid)
-              #,(fail failid (car vars)
+              #,(parse:pks (cdr vars) (cdr fcs) phi (cdr ds) (shift-pks:id pks #'result))
+              #,(fail phi (car vars)
                       #:pattern (expectation-of-stxclass stxclass #'(arg-var ...) #'result)
                       #:fce (join-frontiers (car fcs) #'result)))))))
 
-;; parse:pk:id/any : (listof id) (listof FCE) id stx (listof pk) -> stx
-(define (parse:pk:id/any vars fcs failid args pks)
+;; parse:group:id/any : <ParseConfig> stx (listof pk) -> stx
+(define (parse:group:id/any vars fcs phi ds args pks)
   (with-syntax ([var0 (car vars)]
                 [(arg ...) args]
                 [(arg-var ...) (generate-temporaries args)]
                 [result (generate-temporary 'result)])
     #`(let ([arg-var arg] ...)
         (let ([result (list var0)])
-          #,(parse:pks (cdr vars) (cdr fcs) (shift-pks:id pks #'result) failid)))))
+          #,(parse:pks (cdr vars) (cdr fcs) phi (cdr ds) (shift-pks:id pks #'result))))))
 
-;; parse:pk:c : (listof id) (listof FCE) id ??? ... -> stx
-(define (parse:pk:c vars fcs failid pairpks datumpkss literalpkss)
+;; parse:group:descrim : <ParseConfig>
+;;                       (listof DatumSG) (listof LiteralSG) (listof CompoundSG)
+;;                    -> stx
+(define (parse:group:descrim vars fcs phi ds datumSGs literalSGs compoundSGs)
   (define var (car vars))
   (define datum-var (generate-temporary 'datum))
-  (define (datumpks-test datumpks)
-    (let ([datum (datumpks-datum datumpks)])
+  (define (datumSG-test datumSG)
+    (let ([datum (datumSG-datum datumSG)])
       #`(equal? #,datum-var (quote #,datum))))
-  (define (datumpks-rhs datumpks)
-    (let ([pks (datumpks-pks datumpks)])
-      (parse:pks (cdr vars) (cdr fcs) (shift-pks:datum pks) failid)))
-  (define (literalpks-test literalpks)
-    (let ([literal (literalpks-literal literalpks)])
+  (define (datumSG-rhs datumSG)
+    (let ([pks (datumSG-pks datumSG)])
+      (parse:pks (cdr vars) (cdr fcs) phi (cdr ds) (shift-pks:datum pks))))
+  (define (literalSG-test literalSG)
+    (let ([literal (literalSG-literal literalSG)])
       #`(and (identifier? #,var)
              (free-identifier=? #,var (quote-syntax #,literal)))))
-  (define (literalpks-rhs literalpks)
-    (let ([pks (literalpks-pks literalpks)])
-      (parse:pks (cdr vars) (cdr fcs) (shift-pks:literal pks) failid)))
+  (define (literalSG-rhs literalSG)
+    (let ([pks (literalSG-pks literalSG)])
+      (parse:pks (cdr vars) (cdr fcs) phi (cdr ds) (shift-pks:literal pks))))
+  (define (compoundSG-test compoundSG)
+    (let ([kind (compoundSG-kind compoundSG)])
+      #`(#,(kind-predicate kind) #,datum-var)))
+  (define (compoundSG-rhs compoundSG)
+    (let* ([pks (compoundSG-pks compoundSG)]
+           [kind (compoundSG-kind compoundSG)]
+           [selectors (kind-selectors kind)]
+           [frontier-procs (kind-frontier-procs kind)]
+           [part-vars (for/list ([selector selectors]) (generate-temporary 'part))]
+           [part-frontiers
+            (for/list ([fproc frontier-procs] [part-var part-vars])
+              (fproc (car fcs) part-var))]
+           [part-ds (for/list ([selector selectors]) (car ds))])
+      (with-syntax ([(part-var ...) part-vars]
+                    [(part-expr ...)
+                     (for/list ([selector selectors]) (selector var datum-var))])
+        #`(let ([part-var part-expr] ...)
+            #,(parse:pks (append part-vars (cdr vars))
+                         (append part-frontiers (cdr fcs))
+                         phi
+                         (append part-ds (cdr ds))
+                         (shift-pks:compound pks))))))
   (define-pattern-variable var0 var)
   (define-pattern-variable dvar0 datum-var)
   (define-pattern-variable head-var (generate-temporary 'head))
   (define-pattern-variable tail-var (generate-temporary 'tail))
   (with-syntax ([(datum-clause ...)
-                 (for/list ([datumpks datumpkss])
-                   #`[#,(datumpks-test datumpks) #,(datumpks-rhs datumpks)])]
+                 (for/list ([datumSG datumSGs])
+                   #`[#,(datumSG-test datumSG) #,(datumSG-rhs datumSG)])]
                 [(lit-clause ...)
-                 (for/list ([literalpks literalpkss])
-                   #`[#,(literalpks-test literalpks) #,(literalpks-rhs literalpks)])])
+                 (for/list ([literalSG literalSGs])
+                   #`[#,(literalSG-test literalSG) #,(literalSG-rhs literalSG)])]
+                [(compound-clause ...)
+                 (for/list ([compoundSG compoundSGs])
+                   #`[#,(compoundSG-test compoundSG) #,(compoundSG-rhs compoundSG)])])
     #`(let ([dvar0 (if (syntax? var0) (syntax-e var0) var0)])
-        (cond #,@(if (pair? pairpks)
-                     #`([(pair? dvar0)
-                         (let ([head-var (car dvar0)]
-                               [tail-var (datum->syntax var0 (cdr dvar0) var0)])
-                           #,(parse:pks (list* #'head-var #'tail-var (cdr vars))
-                                        (list* (frontier:add-car (car fcs) #'head-var)
-                                               (frontier:add-cdr (car fcs))
-                                               (cdr fcs))
-                                        (shift-pks:pair pairpks)
-                                        failid))])
-                     #`())
+        (cond compound-clause ...
               lit-clause ...
               datum-clause ...
               [else
-               #,(fail failid (car vars)
+               #,(fail phi (car vars)
                        #:pattern (expectation-of-constants
-                                  (pair? pairpks)
-                                  (for/list ([d datumpkss])
-                                    (datumpks-datum d))
-                                  (for/list ([l literalpkss])
-                                    (literalpks-literal l)))
+                                  (pair? compoundSGs)
+                                  (for/list ([d datumSGs])
+                                    (datumSG-datum d))
+                                  (for/list ([l literalSGs])
+                                    (literalSG-literal l))
+                                  (car ds))
                        #:fce (car fcs))]))))
 
-;; parse:pk:gseq : (listof id) (listof FCE) id
-;;                 pat:gseq (listof Pattern)
-;;                 ???
-;;              -> stx
-(define (parse:pk:gseq vars fcs failid gseq-pattern rest-patterns k)
+;; parse:gseq:and : <ParseConfig> pat:and (listof Pattern) stx
+;;               -> stx
+(define (parse:group:and vars fcs phi ds and-pattern rest-patterns k)
+  (match-define (struct pat:and (orig-stx attrs depth description patterns))
+                and-pattern)
+  ;; FIXME: handle description
+  (let ([var0-copies (for/list ([p patterns]) (car vars))]
+        [fc0-copies (for/list ([p patterns]) (car fcs))]
+        [ds-copies (for/list ([p patterns]) (or description (car ds)))])
+    (parse:pks (append var0-copies (cdr vars))
+               (append fc0-copies (cdr fcs))
+               phi
+               (append ds-copies (cdr ds))
+               (list (make pk (append patterns rest-patterns) k)))))
+
+;; parse:compound:gseq : <ParseConfig> pat:gseq (listof Pattern) stx
+;;                    -> stx
+(define (parse:group:gseq vars fcs phi ds gseq-pattern rest-patterns k)
   (match-define (struct pat:gseq (orig-stx attrs depth heads tail)) gseq-pattern)
   (define xvar (generate-temporary 'x))
   (define head-lengths (for/list ([head heads]) (length (head-ps head))))
@@ -269,9 +328,7 @@
   (define hid-initss
     (for/list ([head heads] [head-attrs head-attrss])
       (for/list ([head-attr head-attrs])
-        (cond [(head-default head)
-               => (lambda (x) #`(quote-syntax #,x))]
-              [(head-as-list? head) #'null]
+        (cond [(head-as-list? head) #'null]
               [else #'#f]))))
   (define combinerss
     (for/list ([head heads] [head-attrs head-attrss])
@@ -309,9 +366,6 @@
                    (if maxrep
                        #`(< #,repvar #,maxrep)
                        #`#t))]
-                [(occurs-binding ...)
-                 (for/list ([head heads] [rep reps] #:when (head-occurs head))
-                   #`[#,(head-occurs head) (positive? #,rep)])]
                 [(parse-loop failkv fail-tail)
                  (generate-temporaries #'(parse-loop failkv fail-tail))])
 
@@ -344,12 +398,12 @@
         #`(cond minrep-clause ...
                 [else
                  (let ([hid (finalize hid-arg)] ... ...
-                       occurs-binding ...
                        [fail-tail enclosing-fail])
                    #,(parse:pks (cdr vars)
                                 (cdr fcs)
-                                (list (make-pk rest-patterns k))
-                                #'fail-tail))])))
+                                #'fail-tail
+                                (cdr ds)
+                                (list (make-pk rest-patterns k))))])))
 
     (with-syntax ([tail-rhs tail-rhs-expr]
                   [(rhs ...)
@@ -366,31 +420,33 @@
             #,(parse:pks (list #'x)
                          (list (frontier:add-index (car fcs)
                                                    #'(calculate-index rep ...)))
+                         #'failkv
+                         (list (car ds))
                          (append
                           (map make-pk
                                (map list completed-heads)
                                (syntax->list #'(rhs ...)))
-                          (list (make-pk (list tail) #`tail-rhs)))
-                         #'failkv))
+                          (list (make-pk (list tail) #`tail-rhs)))))
           (let ([hid hid-init] ... ...
                 [rep 0] ...)
-            (parse-loop var0 hid ... ... rep ... #,failid))))))
-
+            (parse-loop var0 hid ... ... rep ... #,phi))))))
 
 ;; complete-heads-patterns : Head identifier number stx -> Pattern
 (define (complete-heads-pattern head rest-var depth seq-orig-stx)
   (define (loop ps pat)
     (if (pair? ps)
-        (make-pat:pair (cons (pattern-orig-stx (car ps)) (pattern-orig-stx pat))
-                       (append (pattern-attrs (car ps)) (pattern-attrs pat))
-                       depth
-                       (car ps)
-                       (loop (cdr ps) pat))
+        (make pat:compound
+              (cons (pattern-orig-stx (car ps)) (pattern-orig-stx pat))
+              (append (pattern-attrs (car ps)) (pattern-attrs pat))
+              depth
+              pairK
+              (list (car ps) (loop (cdr ps) pat)))
         pat))
   (define base 
-    (make-pat:id seq-orig-stx
-                 (list (make-attr rest-var depth null))
-                 depth rest-var #f null))
+    (make pat:id
+          seq-orig-stx
+          (list (make-attr rest-var depth null))
+          depth rest-var #f null))
   (loop (head-ps head) base))
 
 ;; split-pks : (listof identifier) (listof PK)
@@ -406,7 +462,7 @@
 (define (split-pks/first-column pks)
   (define (get-pat x) (car (pk-ps x)))
   (define (constructor-pat? p)
-    (or (pat:pair? p) (pat:datum? p) (pat:literal? p)))
+    (or (pat:compound? p) (pat:datum? p) (pat:literal? p)))
   (define (constructor-pk? pk)
     (constructor-pat? (get-pat pk)))
   (define (id-pk? pk)
@@ -453,13 +509,17 @@
         (pat:id? p2)
         (and (pat:datum? p1) (pat:datum? p2)
              (equal? (pat:datum-datum p1) (pat:datum-datum p2)))
-        (and (pat:pair? p1) (pat:pair? p2)
-             (pattern-intersects? (pat:pair-head p1) (pat:pair-head p2))
-             (pattern-intersects? (pat:pair-tail p1) (pat:pair-tail p2)))
+        (and (pat:compound? p1) (pat:compound? p2)
+             (eq? (pat:compound-kind p1) (pat:compound-kind p2))
+             (andmap pattern-intersects?
+                     (pat:compound-patterns p1)
+                     (pat:compound-patterns p2)))
         ;; FIXME: conservative
         (and (pat:literal? p1) (pat:literal? p2))
         (pat:gseq? p1)
-        (pat:gseq? p2)))
+        (pat:gseq? p2)
+        (pat:and? p1)
+        (pat:and? p2)))
 
   (define (major-loop pks epks)
     (match pks
@@ -481,18 +541,17 @@
                                tail
                                (list head)
                                null)])
-           (let ([id-epk (make idpks this-stxclass this-args (reverse r-id-pks))])
+           (let ([id-epk (make idG this-stxclass this-args (reverse r-id-pks))])
              (major-loop tail (cons id-epk epks)))))]
+      ;; Leave gseq- and and-patterns by themselves (at least for now)
       [(cons head tail)
        (major-loop tail (cons head epks))]))
 
   ;; gather : (PK -> boolean) (listof PK) (listof PK) (listof PK)
   ;;       -> (listof PK) (listof PK)
   (define (gather pred pks taken prefix)
-    #;(printf "called gather (~s pks, ~s prefix)\n" (length pks) (length prefix))
     (match pks
       ['()
-       #;(printf "took ~s, left ~s\n" (length taken) (length prefix))
        (values taken (reverse prefix))]
       [(cons pk tail)
        ;; We can have it if it can move past everything in the prefix.
@@ -504,16 +563,18 @@
 
   ;; group-constructor-pks : (listof PK) -> ExtPK
   (define (group-constructor-pks reversed-pks)
-    (define pairpks null)
-    (define ht (make-hash))
+    (define compound-ht (make-hasheq))
+    (define datum-ht (make-hash))
     (define lit-ht (make-bound-identifier-mapping))
     (for ([pk reversed-pks])
       (let ([p (get-pat pk)])
-        (cond [(pat:pair? p)
-               (set! pairpks (cons pk pairpks))]
+        (cond [(pat:compound? p)
+               (let ([kind (pat:compound-kind p)])
+                 (hash-set! compound-ht
+                            kind (cons pk (hash-ref compound-ht kind null))))]
               [(pat:datum? p)
                (let ([d (pat:datum-datum p)])
-                 (hash-set! ht d (cons pk (hash-ref ht d null))))]
+                 (hash-set! datum-ht d (cons pk (hash-ref datum-ht d null))))]
               [(pat:literal? p)
                (let ([lit (pat:literal-literal p)])
                  (bound-identifier-mapping-put!
@@ -522,9 +583,10 @@
                   (cons pk
                         (bound-identifier-mapping-get lit-ht lit
                                                       (lambda () null)))))])))
-    (let ([datumpkss (hash-map ht make-datumpks)]
-          [litpkss (bound-identifier-mapping-map lit-ht make-literalpks)])
-      (make cpks pairpks datumpkss litpkss)))
+    (let ([datumSGs (hash-map datum-ht make-datumSG)]
+          [literalSGs (bound-identifier-mapping-map lit-ht make-literalSG)]
+          [compoundSGs (hash-map compound-ht make-compoundSG)])
+      (make descrimG datumSGs literalSGs compoundSGs)))
 
   (major-loop pks null))
 
@@ -565,13 +627,14 @@
     (make-pk (cdr (pk-ps pk)) (pk-k pk)))
   (map shift-pk pks))
 
-;; shift-pks:pair : (listof PK) -> (listof PK)
-(define (shift-pks:pair pks)
+;; shift-pks:compound : (listof PK) -> (listof PK)
+(define (shift-pks:compound pks)
   (define (shift-pk pk0)
     (match pk0
-      [(struct pk ((cons (struct pat:pair (orig-stx attrs depth head tail)) rest-ps)
+      [(struct pk ((cons (struct pat:compound (orig-stx attrs depth kind patterns))
+                         rest-ps)
                    k))
-       (make-pk (list* head tail rest-ps) k)]))
+       (make-pk (append patterns rest-ps) k)]))
   (map shift-pk pks))
 
 ;; wrap-pvars : (listof IAttr) stx -> stx
diff --git a/collects/stxclass/private/rep-data.ss b/collects/stxclass/private/rep-data.ss
index 9464f7bb23..6de85b445f 100644
--- a/collects/stxclass/private/rep-data.ss
+++ b/collects/stxclass/private/rep-data.ss
@@ -14,8 +14,11 @@
          (struct-out pat:id)
          (struct-out pat:datum)
          (struct-out pat:literal)
-         (struct-out pat:pair)
+         (struct-out pat:compound)
          (struct-out pat:gseq)
+         (struct-out pat:and)
+         (struct-out pat:orseq)
+         (struct-out kind)
          (struct-out head)
          (struct-out clause:when)
          (struct-out clause:with))
@@ -53,18 +56,24 @@
 ;;   (make-pat:pair <Pattern> Pattern Pattern)
 ;;   (make-pat:seq <Pattern> Pattern Pattern)
 ;;   (make-pat:gseq <Pattern> (listof Head) Pattern)
+;;   (make-pat:and <Pattern> string/#f (listof Pattern))
+;;   (make-pat:compound <Pattern> Kind (listof Pattern))
 ;; when <Pattern> = stx (listof IAttr) number
 (define-struct pattern (orig-stx attrs depth) #:transparent)
 (define-struct (pat:id pattern) (name stxclass args) #:transparent)
 (define-struct (pat:datum pattern) (datum) #:transparent)
 (define-struct (pat:literal pattern) (literal) #:transparent)
-(define-struct (pat:pair pattern) (head tail) #:transparent)
 (define-struct (pat:gseq pattern) (heads tail) #:transparent)
+(define-struct (pat:and pattern) (description subpatterns) #:transparent)
+(define-struct (pat:orseq pattern) (heads) #:transparent)
+(define-struct (pat:compound pattern) (kind patterns) #:transparent)
+
+;; A Kind is (make-kind id (listof (id id -> stx)) (listof (FCE id -> FCE)))
+(define-struct kind (predicate selectors frontier-procs) #:transparent)
 
 ;; A Head is
 ;;   (make-head stx (listof IAttr) nat (listof Pattern) nat/f nat/f boolean id/#f stx/#f)
-(define-struct head (orig-stx attrs depth ps min max as-list? occurs default)
-  #:transparent)
+(define-struct head (orig-stx attrs depth ps min max as-list?) #:transparent)
 
 ;; A SideClause is one of
 ;;   (make-clause:with pattern stx)
@@ -84,7 +93,6 @@
   (and (attr? a) (symbol? (attr-name a))))
 
 
-
 ;; Environments
 
 ;; DeclEnv maps [id => DeclEntry]
diff --git a/collects/stxclass/private/rep.ss b/collects/stxclass/private/rep.ss
index 00bdf50365..6eaf1a90a9 100644
--- a/collects/stxclass/private/rep.ss
+++ b/collects/stxclass/private/rep.ss
@@ -6,7 +6,8 @@
          syntax/boundmap
          syntax/stx
          "../util.ss"
-         "rep-data.ss")
+         "rep-data.ss"
+         "codegen-data.ss")
 
 (provide/contract
  [parse-whole-pattern 
@@ -21,7 +22,10 @@
       rhs?)]
  [check-literals-list
   (-> syntax?
-      (listof (list/c identifier? identifier?)))])
+      (listof (list/c identifier? identifier?)))]
+ [pairK kind?]
+ [vectorK kind?]
+ [boxK kind?])
 
 (define (atomic-datum? stx)
   (let ([datum (syntax-e stx)])
@@ -47,6 +51,40 @@
   (and (identifier? stx)
        (free-identifier=? stx (quote-syntax ...*))))
 
+(define (and-kw? stx)
+  (and (identifier? stx)
+       (free-identifier=? stx (quote-syntax ~and))))
+
+(define (orseq-kw? stx)
+  (and (identifier? stx)
+       (free-identifier=? stx (quote-syntax ~or))))
+
+(define (reserved? stx)
+  (or (dots? stx)
+      (gdots? stx)
+      (and-kw? stx)
+      (orseq-kw? stx)))
+
+;; ---- Kinds ----
+
+(define pairK
+  (make-kind #'pair?
+             (list (lambda (s d) #`(car #,d))
+                   (lambda (s d) #`(datum->syntax #,s (cdr #,d) #,s)))
+             (list (lambda (fc x) (frontier:add-car fc x))
+                   (lambda (fc x) (frontier:add-cdr fc)))))
+
+(define vectorK
+  (make-kind #'vector?
+             (list (lambda (s d)
+                     #`(datum->syntax #,s (vector->list #,d) #,s)))
+             (list (lambda (fc x) (frontier:add-unvector fc)))))
+
+(define boxK
+  (make-kind #'box?
+             (list (lambda (s d) #`(unbox #,d)))
+             (list (lambda (fc x) (frontier:add-unbox fc)))))
+
 ;; ---
 
 ;; parse-rhs : stx(SyntaxClassRHS) boolean stx -> RHS
@@ -146,12 +184,15 @@
   pattern)
 
 ;; parse-pattern : stx(Pattern) DeclEnv number -> Pattern
-(define (parse-pattern stx decls depth)
-  (syntax-case stx ()
-    [dots
-     (or (dots? #'dots)
-         (gdots? #'dots))
-     (wrong-syntax stx "ellipses not allowed here")]
+(define (parse-pattern stx decls depth
+                       #:allow-orseq-pattern? [allow-orseq-pattern? #f])
+  (syntax-case stx (~and ~or)
+    [gdots
+     (gdots? #'gdots)
+     (wrong-syntax stx "obsolete (...*) sequence syntax")]
+    [reserved
+     (reserved? #'reserved)
+     (wrong-syntax #'reserved "not allowed here")]
     [id
      (identifier? #'id)
      (match (declenv-lookup decls #'id)
@@ -169,25 +210,46 @@
     [datum
      (atomic-datum? #'datum)
      (make pat:datum stx null depth (syntax->datum #'datum))]
-    [(heads gdots . tail)
-     (gdots? #'gdots)
-     (let* ([heads (parse-heads #'heads decls depth)]
-            [tail (parse-pattern #'tail decls depth)]
-            [hattrs (append-attrs (for/list ([head heads]) (head-attrs head)))]
-            [tattrs (pattern-attrs tail)])
-       (make pat:gseq stx (append-attrs (list hattrs tattrs)) depth heads tail))]
+    [(~and . rest)
+     (begin (unless (stx-list? #'rest)
+              (wrong-syntax stx "expected list of patterns"))
+            (parse-and-pattern stx decls depth))]
+    [(~or . heads)
+     (begin (unless (stx-list? #'heads)
+              (wrong-syntax stx "expected list of pattern sequences"))
+            (unless allow-orseq-pattern?
+              (wrong-syntax stx "or/sequence pattern not allowed here"))
+            (let* ([heads (parse-heads #'heads decls depth)]
+                   [attrs
+                    (append-attrs
+                     (for/list ([head heads]) (head-attrs head)))])
+              (make pat:orseq stx attrs depth heads)))]
     [(head dots . tail)
      (dots? #'dots)
-     (let* ([headp (parse-pattern #'head decls (add1 depth))]
+     (let* ([headp (parse-pattern #'head decls (add1 depth)
+                                  #:allow-orseq-pattern? #t)]
+            [heads
+             (if (pat:orseq? headp)
+                 (pat:orseq-heads headp)
+                 (list (pattern->head headp)))]
             [tail (parse-pattern #'tail decls depth)]
-            [head (pattern->head headp)]
-            [attrs (append-attrs (list (head-attrs head) (pattern-attrs tail)))])
-       (make pat:gseq stx attrs depth (list head) tail))]
+            [hattrs (pattern-attrs headp)]
+            [tattrs (pattern-attrs tail)])
+       (make pat:gseq stx (append-attrs (list hattrs tattrs))
+             depth heads tail))]
     [(a . b)
      (let ([pa (parse-pattern #'a decls depth)]
            [pb (parse-pattern #'b decls depth)])
-       (let ([attrs (append-attrs (list (pattern-attrs pa) (pattern-attrs pb)))])
-         (make pat:pair stx attrs depth pa pb)))]))
+       (define attrs
+         (append-attrs (list (pattern-attrs pa) (pattern-attrs pb))))
+       (make pat:compound stx attrs depth pairK (list pa pb))
+       #| (make pat:pair stx attrs depth pa pb) |#)]
+    [#(a ...)
+     (let ([lp (parse-pattern (syntax/loc stx (a ...)) decls depth)])
+       (make pat:compound stx (pattern-attrs lp) depth vectorK (list lp)))]
+    [#&x
+     (let ([bp (parse-pattern #'x decls depth)])
+       (make pat:compound stx (pattern-attrs bp) depth boxK (list bp)))]))
 
 (define (id-pattern-attrs name sc depth)
   (cond [(wildcard? name) null]
@@ -201,16 +263,27 @@
         [else
          (list (make attr name depth null))]))
 
+;; parse-and-patttern : stxlist DeclEnv nat -> Pattern
+(define (parse-and-pattern stx decls depth)
+  (define-values (chunks rest)
+    (chunk-kw-seq/no-dups (stx-cdr stx) and-pattern-directive-table))
+  (define description
+    (cond [(assq '#:description chunks) => caddr]
+          [else #f]))
+  (define patterns
+    (for/list ([x (stx->list rest)])
+      (parse-pattern x decls depth)))
+  (define attrs (append-attrs (map pattern-attrs patterns)))
+  (make pat:and stx attrs depth description patterns))
+
 (define (pattern->head p)
   (match p
     [(struct pattern (orig-stx iattrs depth))
-     (make head orig-stx iattrs depth (list p) #f #f #t #f #f)]))
+     (make head orig-stx iattrs depth (list p) #f #f #t)]))
 
 (define head-directive-table
   (list (list '#:min check-nat/f)
         (list '#:max check-nat/f)
-        (list '#:occurs check-id)
-        (list '#:default values)
         (list '#:opt)
         (list '#:mand)))
 
@@ -221,7 +294,6 @@
                    "empty head sequence not allowed")]
     [({p ...} . more)
      (let-values ([(chunks rest) (chunk-kw-seq/no-dups #'more head-directive-table)])
-       (reject-duplicate-chunks chunks) ;; FIXME: needed?
        (cons (parse-head/chunks (stx-car stx) decls enclosing-depth chunks)
              (parse-heads rest decls enclosing-depth)))]
     [()
@@ -232,11 +304,9 @@
                          [else #f])
                    "expected sequence of patterns or sequence directive")]))
 
-(define (parse-head/chunks pstx decls enclosing-depth chunks)
+(define (parse-head/chunks pstx decls depth chunks)
   (let* ([min-row (assq '#:min chunks)]
          [max-row (assq '#:max chunks)]
-         [occurs-row (assq '#:occurs chunks)]
-         [default-row (assq '#:default chunks)]
          [opt-row (assq '#:opt chunks)]
          [mand-row (assq '#:mand chunks)]
          [min-stx (and min-row (caddr min-row))]
@@ -252,44 +322,25 @@
     (when (and (or min-row max-row) (or opt-row mand-row))
       (wrong-syntax (or min-stx max-stx)
                     "min/max-constraints are incompatible with opt/mand directives"))
-    (when default-row
-      (unless opt-row
-        (wrong-syntax (cadr default-row)
-                      "default only allowed for optional patterns")))
     (parse-head/options pstx
                         decls
-                        enclosing-depth
+                        depth
                         (cond [opt-row 0] [mand-row 1] [else min])
                         (cond [opt-row 1] [mand-row 1] [else max])
-                        (not (or opt-row mand-row))
-                        (and occurs-row (caddr occurs-row))
-                        default-row)))
+                        (not (or opt-row mand-row)))))
 
-(define (parse-head/options pstx decls enclosing-depth 
-                            min max as-list? occurs-pvar default-row)
-  (let* ([depth (if as-list? (add1 enclosing-depth) enclosing-depth)]
+(define (parse-head/options pstx decls depth min max as-list?)
+  (let* ([effective-depth (if as-list? depth (sub1 depth))]
          [heads
-          (for/list ([p (syntax->list pstx)])
-            (parse-pattern p decls depth))]
+          (for/list ([p (stx->list pstx)])
+            (parse-pattern p decls effective-depth))]
          [heads-attrs
           (append-attrs (map pattern-attrs heads))])
-    (when default-row
-      (unless (and (= (length heads-attrs) 1)
-                   (= enclosing-depth (attr-depth (car heads-attrs)))
-                   (null? (attr-inner (car heads-attrs))))
-        (wrong-syntax (cadr default-row)
-                      "default only allowed for patterns with single simple pattern variable")))
-    (let ([occurs-attrs
-           (if occurs-pvar
-               (list (make-attr occurs-pvar depth null))
-               null)])
-      (make head pstx
-            (append-attrs (list occurs-attrs heads-attrs))
-            depth
-            heads
-            min max as-list?
-            occurs-pvar
-            (and default-row (caddr default-row))))))
+    (make head pstx
+          heads-attrs
+          depth
+          heads
+          min max as-list?)))
 
 ;; parse-pattern-directives : stxs(PatternDirective) #:literals (listof id+id)
 ;;                         -> stx DeclEnv RemapEnv (listof SideClause)
@@ -358,6 +409,13 @@
      '()]))
 
 
+;; check-lit-string : stx -> string
+(define (check-lit-string stx)
+  (let ([x (syntax-e stx)])
+    (unless (string? x)
+      (wrong-syntax stx "expected string literal"))
+    x))
+
 ;; check-attr-arity-list : stx -> (listof SAttr)
 (define (check-attr-arity-list stx)
   (unless (stx-list? stx)
@@ -421,3 +479,7 @@
         (list '#:rename check-id check-id)
         (list '#:with values values)
         (list '#:when values)))
+
+;; and-pattern-directive-table
+(define and-pattern-directive-table
+  (list (list '#:description check-lit-string)))
diff --git a/collects/stxclass/private/runtime.ss b/collects/stxclass/private/runtime.ss
index aea51fb425..df7c7cc61a 100644
--- a/collects/stxclass/private/runtime.ss
+++ b/collects/stxclass/private/runtime.ss
@@ -9,6 +9,8 @@
          (for-syntax "../util/error.ss"))
 (provide pattern
          basic-syntax-class
+         ~and
+         ~or
          ...*
 
          with-enclosing-fail
@@ -41,8 +43,9 @@
 
 (define-keyword pattern)
 (define-keyword basic-syntax-class)
+(define-keyword ~and)
+(define-keyword ~or)
 (define-keyword ...*)
-(define-keyword ...**)
 
 ;; Parameters & Syntax Parameters
 
@@ -106,8 +109,8 @@
 ;; Runtime: parsing failures/expectations
 
 ;; An Expectation is
-;;   (make-expc (listof scdyn) (listof expc) (listof atom) (listof id))
-(define-struct expc (stxclasses pairs? data literals)
+;;   (make-expc (listof scdyn) (listof string/#t) (listof atom) (listof id))
+(define-struct expc (stxclasses compound data literals)
   #:transparent)
 
 (define-struct scdyn (name desc failure)
@@ -116,7 +119,7 @@
 (define expectation/c (or/c expc?))
 
 (define (make-stxclass-expc scdyn)
-  (make-expc (list scdyn) #f null null))
+  (make-expc (list scdyn) null null null))
 
 (begin-for-syntax
   (define certify (syntax-local-certifier))
@@ -131,18 +134,22 @@
                     (make-scdyn 'name (desc-var arg ...)
                                 (if (failed? #,result-var) #,result-var #f)))))))
 
-  (define (expectation-of-constants pairs? data literals)
+  (define (expectation-of-constants pairs? data literals description)
     (with-syntax ([(datum ...) data]
                   [(literal ...) literals]
-                  [pairs? pairs?])
+                  [pairs? pairs?]
+                  [description
+                   (if pairs?
+                       (list (or description #t))
+                       null)])
       (certify
-       #'(make-expc null 'pairs? (list 'datum ...)
+       #'(make-expc null 'description (list 'datum ...)
                     (list (quote-syntax literal) ...)))))
 
   (define (expectation-of/message msg)
     (with-syntax ([msg msg])
       (certify
-       #'(make-expc '() #f '((msg)) '())))))
+       #'(make-expc '() '() '((msg)) '())))))
 
 (define-syntax (try stx)
   (syntax-case stx ()
@@ -174,7 +181,7 @@
 
 (define (merge-expectations e1 e2)
   (make-expc (union (expc-stxclasses e1) (expc-stxclasses e2))
-             (or (expc-pairs? e1) (expc-pairs? e2))
+             (union (expc-compound e1) (expc-compound e2))
              (union (expc-data e1) (expc-data e2))
              (union (expc-literals e1) (expc-literals e2))))
 
@@ -183,9 +190,9 @@
 
 (define (expectation-of-null? e)
   (match e
-    [(struct expc (scs pairs? data literals))
+    [(struct expc (scs compound data literals))
      (and (null? scs)
-          (not pairs?)
+          (null? compound)
           (null? literals)
           (and (pair? data) (null? (cdr data)))
           (equal? (car data) '()))]
@@ -193,16 +200,18 @@
 
 (define (expectation->string e)
   (match e
-    [(struct expc (_ #t _ _))
-     #f]
-    [(struct expc (stxclasses pairs? data literals))
-     (let ([s1 (and (pair? stxclasses) (string-of-stxclasses stxclasses))]
-           [s2 (and (pair? data) (string-of-data data))]
-           [s3 (and (pair? literals) (string-of-literals literals))]
-           [s4 (and pairs? string-of-pairs?)])
-       (join-sep (filter string? (list s1 s2 s3 s4))
-                 ";"
-                 "or"))]))
+    [(struct expc (stxclasses compound data literals))
+     (cond [(null? compound)
+            (let ([s1 (and (pair? stxclasses) (string-of-stxclasses stxclasses))]
+                  [s2 (and (pair? data) (string-of-data data))]
+                  [s3 (and (pair? literals) (string-of-literals literals))])
+              (join-sep (filter string? (list s1 s2 s3))
+                        ";"
+                        "or"))]
+           [(andmap string? compound)
+            (join-sep compound ";" "or")]
+           [else
+            #f])]))
 
 (define (string-of-stxclasses scdyns)
   (comma-list (map string-of-stxclass scdyns)))
diff --git a/collects/stxclass/private/sc.ss b/collects/stxclass/private/sc.ss
index a74c93fce4..7e5d702c9f 100644
--- a/collects/stxclass/private/sc.ss
+++ b/collects/stxclass/private/sc.ss
@@ -24,6 +24,8 @@
 
          pattern
          basic-syntax-class
+         ~and
+         ~or
          ...*
 
          attribute
diff --git a/collects/stxclass/scribblings/parsing-syntax.scrbl b/collects/stxclass/scribblings/parsing-syntax.scrbl
index 8e9ae9b039..93d253320a 100644
--- a/collects/stxclass/scribblings/parsing-syntax.scrbl
+++ b/collects/stxclass/scribblings/parsing-syntax.scrbl
@@ -55,15 +55,21 @@ procedure accepts a single argument, which should be a syntax object.
 The grammar of patterns accepted by @scheme[syntax-parse] and
 @scheme[syntax-parser] follows:
 
-@schemegrammar*[#:literals (_ ...*)
+@schemegrammar*[#:literals (_ ~or ~and)
                 [syntax-pattern
                  pvar-id
                  pvar-id:syntax-class-id
                  literal-id
                  atomic-datum
                  (syntax-pattern . syntax-pattern)
-                 (syntax-pattern #,ellipses . syntax-pattern)
-                 ((head ...+) ...* . syntax-pattern)]
+                 (ellipsis-head-pattern #,ellipses . syntax-pattern)
+                 (~and maybe-description syntax-pattern ...)]
+                [ellipsis-head-pattern
+                 (~or head ...+)
+                 syntax-pattern]
+                [maybe-description
+                 (code:line)
+                 (code:line #:description string)]
                 [pvar-id
                  _
                  id]]
@@ -116,17 +122,8 @@ Matches a syntax pair whose head matches the first pattern and whose
 tail matches the second.
 
 }
-@;{
-@specsubform[(syntax-splice-pattern . syntax-pattern)]{
 
-Matches a syntax object which consists of any sequence of syntax
-objects matching the splice pattern followed by a tail matching the
-given tail pattern.
-
-}
-}
-
-@specsubform[(syntax-pattern #,ellipses . syntax-pattern)]{
+@specsubform[(ellipsis-head-pattern #,ellipses . syntax-pattern)]{
 
 Matches a sequence of the first pattern ending in a tail matching the
 second pattern.
@@ -135,23 +132,21 @@ That is, the sequence pattern matches either the second pattern (which
 need not be a list) or a pair whose head matches the first pattern and
 whose tail recursively matches the whole sequence pattern.
 
-}
-@specsubform/subs[#:literals (...*)
-                  ((head ...+) ...* . syntax-pattern)
+The head pattern can be either an ordinary pattern or an
+or/sequence-pattern:
+
+@specsubform/subs[#:literals (~or)
+                  (~or head ...+)
                   ([head
                     (code:line (syntax-pattern ...+) head-directive ...)]
                    [head-directive
                     (code:line #:min min-reps)
                     (code:line #:max max-reps)
-                    (code:line #:mand)
-                    #| (code:line #:opt)
-                       (code:line #:occurs occurs-pvar-id)
-                       (code:line #:default default-form)
-                    |#])]{
+                    (code:line #:mand)])]{
 
-Matches a sequence of any combination of the heads ending in a tail
-matching the final pattern. The match is subject to constraints
-specified on the heads.
+If the head is an or/sequence-pattern (introduced by @scheme[~or]),
+then the whole sequence pattern matches any combination of the head
+sequences followed by a tail matching the final pattern.
 
 @specsubform[(code:line #:min min-reps)]{
 
@@ -175,27 +170,16 @@ in the preceding head are not bound at a higher ellipsis nesting
 depth.
 
 }
-@;{
-@specsubform[#:opt]{
-
-(Probably a bad idea.)
-
 }
 }
-}
-@;{
-The variants of @scheme[_syntax-splice-pattern] follow:
+@specsubform/subs[#:literals (~and)
+                  (~and maybe-description syntax-pattern ...)
+                  ([maybe-description
+                    (code:line)
+                    (code:line #:description string)])]{
 
-@specsubform[pvar-id:syntax-splice-class-id]{
+Matches any syntax that matches all of the included patterns.
 
-Matches a sequence of syntax objects described by
-@scheme[_syntax-splice-class-id].
-
-The name @scheme[_pvar-id] is bound, but not allowed within
-expressions or @scheme[syntax] templates (since it does not refer to a
-particular syntax object). Only the prefixed attributes of the splice
-class are usable.
-}
 }
 
 Both @scheme[syntax-parse] and @scheme[syntax-parser] support
@@ -241,10 +225,19 @@ backtracks as described above; otherwise, it continues.
 
 }
 
-@defidform[...*]{
+
+@defidform[~and]{
 
 Keyword recognized by @scheme[syntax-parse] etc as notation for
-generalized sequences. It may not be used as an expression.
+and-patterns.
+
+}
+
+@defidform[~or]{
+
+Keyword recognized by @scheme[syntax-parse] etc as notation for
+or/sequence-patterns (within sequences). It may not be used as an
+expression.
 
 }
 
diff --git a/collects/tests/stxclass/stxclass.ss b/collects/tests/stxclass/stxclass.ss
index d11e383b08..1ebeb878c2 100644
--- a/collects/tests/stxclass/stxclass.ss
+++ b/collects/tests/stxclass/stxclass.ss
@@ -118,37 +118,37 @@
         (check-equal? (syntax->datum #'(t.a ...)) '(1 4 6)))
       (test-patterns (t:two-to-four/untagged ...) #'((1 2 3) (4 5) (6 7 8))
         (check-equal? (syntax->datum #'(t.b ...)) '(2 5 7)))
-      (test-patterns ({{x:id v:nat} {s:str}} ...*) #'(x 1 y 2 "whee" x 3)
+      (test-patterns ({~or {x:id v:nat} {s:str}} ...) #'(x 1 y 2 "whee" x 3)
         (check-equal? (stx->datum #'((x v) ...)) '((x 1) (y 2) (x 3)))
         (check-equal? (stx->datum #'(s ...)) '("whee")))
-      (test-patterns ({{x:id v:nat} {s:str}} ...*) #'(x 1 y 2 "whee" x 3)
+      (test-patterns ({~or {x:id v:nat} {s:str}} ...) #'(x 1 y 2 "whee" x 3)
         (check-equal? (stx->datum #'((x v) ...)) '((x 1) (y 2) (x 3)))
         (check-equal? (stx->datum #'(s ...)) '("whee")))
-      (test-patterns ({{1} #:min 1 #:max 1
-                       {2} #:min 1 #:max 1
-                       {3} #:min 1 #:max 1} ...*)
+      (test-patterns ({~or {1} #:min 1 #:max 1
+                           {2} #:min 1 #:max 1
+                           {3} #:min 1 #:max 1} ...)
                      #'(1 2 3)
         'ok)
-      (test-patterns ({{a:id} {b:nat} {c:str}} ...*) #'("one" 2 three)
+      (test-patterns ({~or {a:id} {b:nat} {c:str}} ...) #'("one" 2 three)
         (check-equal? (stx->datum #'(a ...)) '(three))
         (check-equal? (stx->datum #'(b ...)) '(2))
         (check-equal? (stx->datum #'(c ...)) '("one")))
-      (test-patterns ({{1} #:min 1 #:max 1
-                       {2} #:min 1 #:max 1
-                       {3} #:min 1 #:max 1
-                       {x} #:min 1 #:max 1
-                       {y} #:min 1 #:max 1
-                       {w} #:min 1 #:max 1} ...*)
+      (test-patterns ({~or {1} #:min 1 #:max 1
+                           {2} #:min 1 #:max 1
+                           {3} #:min 1 #:max 1
+                           {x} #:min 1 #:max 1
+                           {y} #:min 1 #:max 1
+                           {w} #:min 1 #:max 1} ...)
                      #'(1 2 3 x y z)
         (for ([s (syntax->list #'(x ... y ... w ...))]) (check-pred identifier? s))
         (check-equal? (sort 
                        (map symbol->string (stx->datum #'(x ... y ... w ...)))
                        string<?)
                       '("x" "y" "z")))
-      (test-patterns ({{x}
-                       {1} #:min 1 #:max 1
-                       {2} #:min 1 #:max 1
-                       {3} #:min 1 #:max 1} ...*)
+      (test-patterns ({~or {x}
+                           {1} #:min 1 #:max 1
+                           {2} #:min 1 #:max 1
+                           {3} #:min 1 #:max 1} ...)
                      #'(1 2 3 x y z)
         (check-equal? (stx->datum #'(x ...)) '(x y z)))
       )))
diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss
index 526d91843e..135384af86 100644
--- a/collects/typed-scheme/private/parse-type.ss
+++ b/collects/typed-scheme/private/parse-type.ss
@@ -251,7 +251,7 @@
   (pattern (case-lambda f:fun-ty/one ...)
            #:with t (make-Function (syntax->datum #'(f.arr ...))))
   
-  (pattern (t:Class (pos-args:type ...) ([fname:id fty:type ((rest:boolean) #:opt) ...*] ...) ([mname:id mty:type] ...))
+  (pattern (t:Class (pos-args:type ...) ([fname:id fty:type (~or (rest:boolean) #:opt) ...] ...) ([mname:id mty:type] ...))
            #:with t
            (make-Class
             (syntax->datum #'(pos-args.t ...))
diff --git a/collects/typed-scheme/private/prims.ss b/collects/typed-scheme/private/prims.ss
index d34ce7dd0d..3988110b43 100644
--- a/collects/typed-scheme/private/prims.ss
+++ b/collects/typed-scheme/private/prims.ss
@@ -66,7 +66,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
   (syntax-parse stx
     [(_ lib [nm:opt-rename ty] ...)
      #'(begin (require/typed nm ty lib) ...)]
-    [(_ nm:opt-rename ty lib ([#:struct-maker parent] #:opt) ...*)
+    [(_ nm:opt-rename ty lib (~or [#:struct-maker parent] #:opt) ...)
      (with-syntax ([cnt* (generate-temporary #'nm.nm)]
 		   [sm (if #'parent
                            #'(#:struct-maker parent)
@@ -87,7 +87,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
   (define-syntax-class name-exists-kw
     (pattern #:name-exists))
   (syntax-parse stx
-    [(_ ty:id pred:id lib ([ne:name-exists-kw] #:opt) ...*)
+    [(_ ty:id pred:id lib (~or [ne:name-exists-kw] #:opt) ...)
      (register-type-name #'ty (make-Opaque #'pred (syntax-local-certifier)))
      (quasisyntax/loc stx
        (begin 
diff --git a/collects/typed-scheme/private/type-abbrev.ss b/collects/typed-scheme/private/type-abbrev.ss
index 3a33b0f34d..35de27f4cc 100644
--- a/collects/typed-scheme/private/type-abbrev.ss
+++ b/collects/typed-scheme/private/type-abbrev.ss
@@ -82,7 +82,7 @@
 
 (define-syntax (->key stx)
   (syntax-parse stx
-                [(_ ty:expr ... ((k:keyword kty:expr opt:boolean)) ...* rng)
+                [(_ ty:expr ... (~or (k:keyword kty:expr opt:boolean)) ... rng)
                  #'(make-Function
                     (list
                      (make-arr* (list ty ...)
diff --git a/collects/typed-scheme/rep/interning.ss b/collects/typed-scheme/rep/interning.ss
index 2430ee4af9..fa696eb829 100644
--- a/collects/typed-scheme/rep/interning.ss
+++ b/collects/typed-scheme/rep/interning.ss
@@ -7,9 +7,9 @@
 
 (define-syntax (defintern stx)
   (syntax-parse stx
-    [(_ name+args make-name key ([#:extra-arg e:expr]) ...*) 
+    [(_ name+args make-name key (~or [#:extra-arg e:expr]) ...) 
      #'(defintern name+args (lambda () (make-hash #;'weak)) make-name key #:extra-arg e ...)]
-    [(_ (*name:id arg:id ...) make-ht make-name key-expr ([#:extra-arg e:expr]) ...*)
+    [(_ (*name:id arg:id ...) make-ht make-name key-expr (~or [#:extra-arg e:expr]) ...)
      #'(define *name
 	 (let ([table (make-ht)])
 	   (lambda (arg ...)
diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/rep/rep-utils.ss
index 2d2ecc7d98..1d97957d70 100644
--- a/collects/typed-scheme/rep/rep-utils.ss
+++ b/collects/typed-scheme/rep/rep-utils.ss
@@ -70,11 +70,11 @@
     (define (mk par ht-stx)        
       (lambda (stx)          
         (syntax-parse stx 
-          [(dform nm:id flds:idlist ([[#:key key-expr:expr]] #:opt 
-				     [[#:intern intern?:expr]] #:opt
-				     [[#:frees . frees:frees-pat]] #:opt
-				     [[#:fold-rhs fold-rhs:fold-pat]] #:opt
-				     [no-provide?:no-provide-kw] #:opt) ...*)
+          [(dform nm:id flds:idlist (~or [[#:key key-expr:expr]] #:opt 
+                                         [[#:intern intern?:expr]] #:opt
+                                         [[#:frees . frees:frees-pat]] #:opt
+                                         [[#:fold-rhs fold-rhs:fold-pat]] #:opt
+                                         [no-provide?:no-provide-kw] #:opt) ...)
 	   (with-syntax* 
 	     ([ex (mk-id #'nm #'nm ":")]
 	      [kw-stx (string->keyword (symbol->string #'nm.datum))]