diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt
index 0e1811657e..268f5157d0 100644
--- a/pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt
+++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt
@@ -53,14 +53,25 @@
   (ctest #t contract-stronger? (or/c null? any/c) (or/c null? any/c))
   (ctest #f contract-stronger? (or/c null? any/c) (or/c boolean? any/c))
   (ctest #t contract-stronger? (or/c null? boolean?) (or/c null? boolean?))
-  (ctest #f contract-stronger? (or/c null? boolean?) (or/c boolean? null?))
+  (ctest #t contract-stronger? (or/c null? boolean?) (or/c boolean? null?))
   (ctest #t contract-stronger? 
          (or/c null? (-> integer? integer?))
          (or/c null? (-> integer? integer?)))
   (ctest #f contract-stronger?
          (or/c null? (-> boolean? boolean?))
          (or/c null? (-> integer? integer?)))
-
+  (ctest #f contract-stronger? (or/c number? #f) number?)
+  (ctest #t contract-stronger? number? (or/c number? #f))
+  (ctest #f contract-stronger? (or/c (-> number? number?) #f) (-> number? number?))
+  (ctest #t contract-stronger? (-> number? number?) (or/c (-> number? number?) #f))
+  (ctest #f contract-stronger? (or/c (-> number? number?) (-> number? number? number?) #f) #f)
+  (ctest #t contract-stronger? #f (or/c (-> number? number?) (-> number? number? number?) #f))
+  (ctest #t contract-stronger? (or/c real?) (or/c integer? real?))
+  (ctest #t contract-stronger? (-> number?) (-> (or/c #f number?)))
+  (ctest #t contract-stronger? (-> (or/c #f number?) any/c) (-> number? any/c))
+  (ctest #f contract-stronger? (-> (or/c #f number?)) (-> number?))
+  (ctest #f contract-stronger? (-> number? any/c) (-> (or/c #f number?) any/c))
+  
   (ctest #t contract-stronger? number? number?)
   (ctest #f contract-stronger? boolean? number?)
 
@@ -102,7 +113,7 @@
   (ctest #f contract-stronger?
         (or/c (-> string?) (-> integer? integer?) integer? char?)
         (or/c (-> string?) (-> integer? integer?) integer? boolean?))
-  (ctest #f contract-stronger?
+  (ctest #t contract-stronger?
         (or/c (-> string?) (-> integer? integer?) integer?)
         (or/c (-> string?) (-> integer? integer?) integer? boolean?))
   (ctest #f contract-stronger?
diff --git a/racket/collects/racket/contract/base.rkt b/racket/collects/racket/contract/base.rkt
index 907e04d2f4..8e3d6c1ada 100644
--- a/racket/collects/racket/contract/base.rkt
+++ b/racket/collects/racket/contract/base.rkt
@@ -16,7 +16,8 @@
          "private/basic-opters.rkt" ;; required for effect to install the opters
          "private/opt.rkt"
          "private/out.rkt"
-         "private/arrow-val-first.rkt")
+         "private/arrow-val-first.rkt"
+         "private/orc.rkt")
 
 (provide
  (except-out (all-from-out "private/arrow.rkt")
@@ -48,6 +49,7 @@
  (except-out (all-from-out "private/misc.rkt")
              check-between/c
              check-unary-between/c)
+ symbols or/c one-of/c
  provide/contract
  ;(for-syntax make-provide/contract-transformer) ;; not documented!
  contract-out
diff --git a/racket/collects/racket/contract/private/guts.rkt b/racket/collects/racket/contract/private/guts.rkt
index 192d90e88f..7ce290d667 100644
--- a/racket/collects/racket/contract/private/guts.rkt
+++ b/racket/collects/racket/contract/private/guts.rkt
@@ -355,9 +355,9 @@
   (build-flat-contract-property
    #:stronger
    (λ (this that) 
-      (and (predicate-contract? that)
-           (procedure-closure-contents-eq? (predicate-contract-pred this)
-                                           (predicate-contract-pred that))))
+     (and (predicate-contract? that)
+          (procedure-closure-contents-eq? (predicate-contract-pred this)
+                                          (predicate-contract-pred that))))
    #:name (λ (ctc) (predicate-contract-name ctc))
    #:first-order (λ (ctc) (predicate-contract-pred ctc))
    #:val-first-projection
diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt
index 77b48e3b5e..e2425a8e30 100644
--- a/racket/collects/racket/contract/private/misc.rkt
+++ b/racket/collects/racket/contract/private/misc.rkt
@@ -11,7 +11,6 @@
 
 (provide flat-rec-contract
          flat-murec-contract
-         or/c 
          and/c
          not/c
          =/c >=/c <=/c </c >/c between/c
@@ -21,7 +20,6 @@
          string-len/c
          false/c
          printable/c
-         symbols one-of/c
          listof non-empty-listof cons/c list/c
          promise/c
          syntax/c
@@ -57,7 +55,6 @@
          contract-name
          n->th
          
-         blame-add-or-context
          blame-add-car-context
          blame-add-cdr-context
          raise-not-cons-blame-error)
@@ -115,307 +112,6 @@
 
 (define (flat-murec-contract/init x) (error 'flat-murec-contract "applied too soon"))
 
-(define/subexpression-pos-prop or/c
-  (case-lambda 
-    [() (make-none/c '(or/c))]
-    [raw-args
-     (define args (coerce-contracts 'or/c raw-args))
-     (define-values (ho-contracts flat-contracts)
-       (let loop ([ho-contracts '()]
-                  [flat-contracts '()]
-                  [args args])
-         (cond
-           [(null? args) (values ho-contracts (reverse flat-contracts))]
-           [else 
-            (let ([arg (car args)])
-              (cond
-                [(flat-contract? arg)
-                 (loop ho-contracts (cons arg flat-contracts) (cdr args))]
-                [else
-                 (loop (cons arg ho-contracts) flat-contracts (cdr args))]))])))
-     (define pred 
-       (cond
-         [(null? flat-contracts) not]
-         [else
-          (let loop ([fst (car flat-contracts)]
-                     [rst (cdr flat-contracts)])
-            (let ([fst-pred (flat-contract-predicate fst)])
-              (cond
-                [(null? rst) fst-pred]
-                [else 
-                 (let ([r (loop (car rst) (cdr rst))])
-                   (λ (x) (or (fst-pred x) (r x))))])))]))
-     
-     (cond
-       [(null? ho-contracts)
-        (make-flat-or/c pred flat-contracts)]
-       [(null? (cdr ho-contracts))
-        (define name (apply build-compound-type-name 'or/c args))
-        (if (chaperone-contract? (car ho-contracts))
-            (make-chaperone-single-or/c name pred flat-contracts (car ho-contracts))
-            (make-impersonator-single-or/c name pred flat-contracts (car ho-contracts)))]
-       [else
-        (define name (apply build-compound-type-name 'or/c args))
-        (if (andmap chaperone-contract? ho-contracts)
-            (make-chaperone-multi-or/c name flat-contracts ho-contracts)
-            (make-impersonator-multi-or/c name flat-contracts ho-contracts))])]))
-
-(define (single-or/c-projection ctc)
-  (let ([c-proc (contract-projection (single-or/c-ho-ctc ctc))]
-        [pred (single-or/c-pred ctc)])
-    (λ (blame)
-      (define partial-contract
-        (c-proc (blame-add-or-context blame)))
-      (λ (val)
-        (cond
-          [(pred val) val]
-          [else (partial-contract val)])))))
-
-(define (single-or/c-val-first-projection ctc)
-  (define c-proj (get/build-val-first-projection (single-or/c-ho-ctc ctc)))
-  (define pred (single-or/c-pred ctc))
-  (λ (blame)
-    (define p-app (c-proj (blame-add-or-context blame)))
-    (λ (val)
-      (if (pred val)
-          (λ (neg-party) val)
-          (p-app val)))))
-
-(define (blame-add-or-context blame)
-  (blame-add-context blame "a disjunct of"))
-
-(define (single-or/c-first-order ctc)
-  (let ([pred (single-or/c-pred ctc)]
-        [ho (contract-first-order (single-or/c-ho-ctc ctc))])
-    (λ (x) (or (ho x) (pred x)))))
-
-(define (single-or/c-stronger? this that)
-  (and (single-or/c? that)
-       (contract-stronger? (single-or/c-ho-ctc this)
-                           (single-or/c-ho-ctc that))
-       (let ([this-ctcs (single-or/c-flat-ctcs this)]
-             [that-ctcs (single-or/c-flat-ctcs that)])
-         (and (= (length this-ctcs) (length that-ctcs))
-              (andmap contract-stronger?
-                      this-ctcs
-                      that-ctcs)))))
-
-(define-struct single-or/c (name pred flat-ctcs ho-ctc))
-
-(define-struct (chaperone-single-or/c single-or/c) ()
-  #:property prop:custom-write custom-write-property-proc
-  #:property prop:chaperone-contract
-  (parameterize ([skip-projection-wrapper? #t])
-    (build-chaperone-contract-property
-     #:projection single-or/c-projection
-     #:val-first-projection single-or/c-val-first-projection
-     #:name single-or/c-name
-     #:first-order single-or/c-first-order
-     #:stronger single-or/c-stronger?)))
-
-(define-struct (impersonator-single-or/c single-or/c) ()
-  #:property prop:custom-write custom-write-property-proc
-  #:property prop:contract
-  (build-contract-property
-   #:projection single-or/c-projection
-   #:val-first-projection single-or/c-val-first-projection
-   #:name single-or/c-name
-   #:first-order single-or/c-first-order
-   #:stronger single-or/c-stronger?))
-
-(define (multi-or/c-proj ctc)
-  (let* ([ho-contracts (multi-or/c-ho-ctcs ctc)]
-         [c-procs (map (λ (x) (contract-projection x)) ho-contracts)]
-         [first-order-checks (map (λ (x) (contract-first-order x)) ho-contracts)]
-         [predicates (map flat-contract-predicate (multi-or/c-flat-ctcs ctc))])
-    (λ (blame)
-      (define disj-blame (blame-add-context blame "a disjunct of"))
-      (define partial-contracts
-        (for/list ([c-proc (in-list c-procs)])
-          (c-proc disj-blame)))
-      (λ (val)
-        (cond
-          [(ormap (λ (pred) (pred val)) predicates)
-           val]
-          [else
-           (let loop ([checks first-order-checks]
-                      [procs partial-contracts]
-                      [contracts ho-contracts]
-                      [candidate-proc #f]
-                      [candidate-contract #f])
-             (cond
-               [(null? checks)
-                (if candidate-proc
-                    (candidate-proc val)
-                    (raise-blame-error blame val 
-                                       '("none of the branches of the or/c matched" given: "~e")
-                                       val))]
-               [((car checks) val)
-                (if candidate-proc
-                    (raise-blame-error blame val
-                                       '("two of the clauses in the or/c might both match: ~s and ~s"
-                                         given:
-                                         "~e")
-                                       (contract-name candidate-contract)
-                                       (contract-name (car contracts))
-                                       val)
-                    (loop (cdr checks)
-                          (cdr procs)
-                          (cdr contracts)
-                          (car procs)
-                          (car contracts)))]
-               [else
-                (loop (cdr checks)
-                      (cdr procs)
-                      (cdr contracts)
-                      candidate-proc
-                      candidate-contract)]))])))))
-
-(define (multi-or/c-val-first-proj ctc)  
-  (define ho-contracts (multi-or/c-ho-ctcs ctc))
-  (define c-projs (map get/build-val-first-projection ho-contracts))
-  (define first-order-checks (map (λ (x) (contract-first-order x)) ho-contracts))
-  (define predicates (map flat-contract-predicate (multi-or/c-flat-ctcs ctc)))
-  (λ (blame)
-    (define blame-w-context (blame-add-or-context blame))
-    (λ (val)
-      (cond
-        [(for/or ([pred (in-list predicates)])
-           (pred val))
-         (λ (neg-party) val)]
-        [else
-         (let loop ([checks first-order-checks]
-                    [c-projs c-projs]
-                    [contracts ho-contracts]
-                    [candidate-c-proj #f]
-                    [candidate-contract #f])
-           (cond
-             [(null? checks)
-              (cond
-                [candidate-c-proj
-                 ((candidate-c-proj blame-w-context) val)]
-                [else
-                 (λ (neg-party)
-                   (raise-blame-error blame val #:missing-party neg-party
-                                      '("none of the branches of the or/c matched" given: "~e")
-                                      val))])]
-             [((car checks) val)
-              (if candidate-c-proj
-                  (λ (neg-party)
-                    (raise-blame-error blame val #:missing-party neg-party
-                                       '("two of the clauses in the or/c might both match: ~s and ~s"
-                                         given:
-                                         "~e")
-                                       (contract-name candidate-contract)
-                                       (contract-name (car contracts))
-                                       val))
-                  (loop (cdr checks)
-                        (cdr c-projs)
-                        (cdr contracts)
-                        (car c-projs)
-                        (car contracts)))]
-             [else
-              (loop (cdr checks)
-                    (cdr c-projs)
-                    (cdr contracts)
-                    candidate-c-proj
-                    candidate-contract)]))]))))
-
-(define (multi-or/c-first-order ctc)
-  (let ([flats (map flat-contract-predicate (multi-or/c-flat-ctcs ctc))]
-        [hos (map (λ (x) (contract-first-order x)) (multi-or/c-ho-ctcs ctc))])
-    (λ (x)
-      (or (ormap (λ (f) (f x)) hos)
-          (ormap (λ (f) (f x)) flats)))))
-
-(define (multi-or/c-stronger? this that)
-  (and (multi-or/c? that)
-       (let ([this-ctcs (multi-or/c-ho-ctcs this)]
-             [that-ctcs (multi-or/c-ho-ctcs that)])
-         (and (= (length this-ctcs) (length that-ctcs))
-              (andmap contract-stronger? this-ctcs that-ctcs)))
-       (let ([this-ctcs (multi-or/c-flat-ctcs this)]
-             [that-ctcs (multi-or/c-flat-ctcs that)])
-         (and (= (length this-ctcs) (length that-ctcs))
-              (andmap contract-stronger? this-ctcs that-ctcs)))))
-
-(define-struct multi-or/c (name flat-ctcs ho-ctcs))
-
-(define-struct (chaperone-multi-or/c multi-or/c) ()
-  #:property prop:custom-write custom-write-property-proc
-  #:property prop:chaperone-contract
-  (parameterize ([skip-projection-wrapper? #t])
-    (build-chaperone-contract-property
-     #:projection multi-or/c-proj
-     #:val-first-projection multi-or/c-val-first-proj
-     #:name multi-or/c-name
-     #:first-order multi-or/c-first-order
-     #:stronger multi-or/c-stronger?)))
-
-(define-struct (impersonator-multi-or/c multi-or/c) ()
-  #:property prop:custom-write custom-write-property-proc
-  #:property prop:contract
-  (build-contract-property
-   #:projection multi-or/c-proj
-   #:val-first-projection multi-or/c-val-first-proj
-   #:name multi-or/c-name
-   #:first-order multi-or/c-first-order
-   #:stronger multi-or/c-stronger?))
-
-(define-struct flat-or/c (pred flat-ctcs)
-  #:property prop:custom-write custom-write-property-proc
-  #:property prop:flat-contract
-  (build-flat-contract-property
-   #:name
-   (λ (ctc)
-      (apply build-compound-type-name 
-             'or/c 
-             (flat-or/c-flat-ctcs ctc)))
-   #:stronger
-   (λ (this that)
-      (and (flat-or/c? that)
-           (let ([this-ctcs (flat-or/c-flat-ctcs this)]
-                 [that-ctcs (flat-or/c-flat-ctcs that)])
-             (cond
-               [(and (<= (length this-ctcs) (length that-ctcs))
-                     (for/and ([this-ctc (in-list this-ctcs)]
-                               [that-ctc (in-list that-ctcs)])
-                       (contract-stronger? this-ctc that-ctc)))
-                #t]
-               [(and (andmap (λ (x) (or (eq-contract? x) (equal-contract? x))) this-ctcs)
-                     (andmap (λ (x) (or (eq-contract? x) (equal-contract? x))) that-ctcs))
-                (define ht (make-hash))
-                (for ([x (in-list that-ctcs)])
-                  (hash-set! ht
-                             (if (equal-contract? x)
-                                 (equal-contract-val x)
-                                 (eq-contract-val x))
-                             #t))
-                (for/and ([x (in-list this-ctcs)])
-                  (hash-ref ht 
-                            (if (equal-contract? x)
-                                (equal-contract-val x)
-                                (eq-contract-val x))
-                            #f))]
-               [else #f]))))
-                    
-
-   #:first-order
-   (λ (ctc) (flat-or/c-pred ctc))
-   #:generate
-   (λ (ctc)
-     (λ (fuel)
-       (define choices 
-         (filter 
-          values
-          (for/list ([ctc (in-list (flat-or/c-flat-ctcs ctc))])
-            (generate/choose ctc fuel))))
-       (cond
-         [(null? choices) #f]
-         [else
-          (lambda ()
-            ((oneof choices)))])))))
-
 
 (define (and-name ctc)
   (apply build-compound-type-name 'and/c (base-and/c-ctcs ctc)))
@@ -554,39 +250,6 @@
      (and (string? x)
           ((string-length x) . < . n)))))
 
-(define/final-prop (symbols s1 . s2s)
-  (define ss (cons s1 s2s))
-  (for ([arg (in-list ss)]
-        [i (in-naturals)])
-    (unless (symbol? arg)
-      (raise-argument-error 'symbols
-                            "symbol?"
-                            i
-                            ss)))
-  (apply or/c ss))
-
-(define atomic-value? 
-  (λ (x)
-     (or (char? x) (symbol? x) (boolean? x)
-         (null? x) (keyword? x) (number? x)
-         (void? x))))
-
-(define/final-prop (one-of/c . elems)
-  (for ([arg (in-list elems)]
-        [i (in-naturals)])
-    (unless (atomic-value? arg)
-      (raise-argument-error 'one-of/c
-                            "char, symbol, boolean, null, keyword, number, or void"
-                            i
-                            elems)))
-  (define or/c-args
-    (map (λ (x)
-           (cond
-             [(void? x) void?]
-             [else x]))
-         elems))
-  (apply or/c or/c-args))
-
 (define-struct between/c (low high)
   #:property prop:custom-write custom-write-property-proc
   #:omit-define-syntaxes
diff --git a/racket/collects/racket/contract/private/orc.rkt b/racket/collects/racket/contract/private/orc.rkt
new file mode 100644
index 0000000000..00814c100d
--- /dev/null
+++ b/racket/collects/racket/contract/private/orc.rkt
@@ -0,0 +1,409 @@
+#lang racket/base
+(require "prop.rkt"
+         "blame.rkt"
+         "guts.rkt"
+         "rand.rkt"
+         "generate.rkt"
+         "misc.rkt")
+
+(provide symbols or/c one-of/c
+         blame-add-or-context)
+
+(define/subexpression-pos-prop or/c
+  (case-lambda 
+    [() (make-none/c '(or/c))]
+    [raw-args
+     (define args (coerce-contracts 'or/c raw-args))
+     (define-values (ho-contracts flat-contracts)
+       (let loop ([ho-contracts '()]
+                  [flat-contracts '()]
+                  [args args])
+         (cond
+           [(null? args) (values ho-contracts (reverse flat-contracts))]
+           [else 
+            (let ([arg (car args)])
+              (cond
+                [(flat-contract? arg)
+                 (loop ho-contracts (cons arg flat-contracts) (cdr args))]
+                [else
+                 (loop (cons arg ho-contracts) flat-contracts (cdr args))]))])))
+     (define pred 
+       (cond
+         [(null? flat-contracts) not]
+         [else
+          (let loop ([fst (car flat-contracts)]
+                     [rst (cdr flat-contracts)])
+            (let ([fst-pred (flat-contract-predicate fst)])
+              (cond
+                [(null? rst) fst-pred]
+                [else 
+                 (let ([r (loop (car rst) (cdr rst))])
+                   (λ (x) (or (fst-pred x) (r x))))])))]))
+     
+     (cond
+       [(null? ho-contracts)
+        (make-flat-or/c pred flat-contracts)]
+       [(null? (cdr ho-contracts))
+        (define name (apply build-compound-type-name 'or/c args))
+        (if (chaperone-contract? (car ho-contracts))
+            (make-chaperone-single-or/c name pred flat-contracts (car ho-contracts))
+            (make-impersonator-single-or/c name pred flat-contracts (car ho-contracts)))]
+       [else
+        (define name (apply build-compound-type-name 'or/c args))
+        (if (andmap chaperone-contract? ho-contracts)
+            (make-chaperone-multi-or/c name flat-contracts ho-contracts)
+            (make-impersonator-multi-or/c name flat-contracts ho-contracts))])]))
+
+(define (single-or/c-projection ctc)
+  (let ([c-proc (contract-projection (single-or/c-ho-ctc ctc))]
+        [pred (single-or/c-pred ctc)])
+    (λ (blame)
+      (define partial-contract
+        (c-proc (blame-add-or-context blame)))
+      (λ (val)
+        (cond
+          [(pred val) val]
+          [else (partial-contract val)])))))
+
+(define (single-or/c-val-first-projection ctc)
+  (define c-proj (get/build-val-first-projection (single-or/c-ho-ctc ctc)))
+  (define pred (single-or/c-pred ctc))
+  (λ (blame)
+    (define p-app (c-proj (blame-add-or-context blame)))
+    (λ (val)
+      (if (pred val)
+          (λ (neg-party) val)
+          (p-app val)))))
+
+(define (blame-add-or-context blame)
+  (blame-add-context blame "a disjunct of"))
+
+(define (single-or/c-first-order ctc)
+  (let ([pred (single-or/c-pred ctc)]
+        [ho (contract-first-order (single-or/c-ho-ctc ctc))])
+    (λ (x) (or (ho x) (pred x)))))
+
+(define (single-or/c-stronger? this that)
+  (or (and (single-or/c? that)
+           (contract-stronger? (single-or/c-ho-ctc this)
+                               (single-or/c-ho-ctc that))
+           (let ([this-ctcs (single-or/c-flat-ctcs this)]
+                 [that-ctcs (single-or/c-flat-ctcs that)])
+             (and (= (length this-ctcs) (length that-ctcs))
+                  (andmap contract-stronger?
+                          this-ctcs
+                          that-ctcs))))
+      (generic-or/c-stronger? this that)))
+
+(define (generic-or/c-stronger? this that)
+  (define this-sub-ctcs (or/c-sub-contracts this))
+  (define that-sub-ctcs (or/c-sub-contracts that))
+  (and this-sub-ctcs
+       that-sub-ctcs
+       (for/and ([this-sub-ctc (in-list this-sub-ctcs)])
+         (for/or ([that-sub-ctc (in-list that-sub-ctcs)])
+           (contract-stronger? this-sub-ctc that-sub-ctc)))))
+
+(define (or/c-sub-contracts ctc)
+  (cond
+    [(single-or/c? ctc)
+     (cons (single-or/c-ho-ctc ctc)
+           (single-or/c-flat-ctcs ctc))]
+    [(multi-or/c? ctc)
+     (append (multi-or/c-flat-ctcs ctc)
+             (multi-or/c-ho-ctcs ctc))]
+    [(flat-or/c? ctc)
+     (flat-or/c-flat-ctcs ctc)]
+    [else #f]))
+
+(define (or/c-exercise ho-contracts)
+  (λ (fuel)
+    (define env (generate-env))
+    (values (λ (val)
+              (let loop ([ho-contracts ho-contracts])
+                (unless (null? ho-contracts)
+                  (define ctc (car ho-contracts))
+                  (cond
+                    [((contract-first-order ctc) val)
+                     (define-values (exercise ctcs) ((contract-struct-exercise ctc) fuel))
+                     (exercise val)
+                     (env-stash env ctc val)]
+                    [else
+                     (loop (cdr ho-contracts))]))))
+            '())))
+
+(define (or/c-generate ctcs)
+  (λ (fuel)
+    (define choices 
+      (filter 
+       values
+       (for/list ([ctc (in-list ctcs)])
+         (generate/choose ctc fuel))))
+    (cond
+      [(null? choices) #f]
+      [else
+       (lambda ()
+         ((oneof choices)))])))
+
+(define-struct single-or/c (name pred flat-ctcs ho-ctc)
+  #:property prop:orc-contract
+  (λ (this) (cons (single-or/c-ho-ctc this) 
+                  (single-or/c-flat-ctcs this))))
+
+(define-struct (chaperone-single-or/c single-or/c) ()
+  #:property prop:custom-write custom-write-property-proc
+  #:property prop:chaperone-contract
+  (parameterize ([skip-projection-wrapper? #t])
+    (build-chaperone-contract-property
+     #:projection single-or/c-projection
+     #:val-first-projection single-or/c-val-first-projection
+     #:name single-or/c-name
+     #:first-order single-or/c-first-order
+     #:stronger single-or/c-stronger?
+     #:generate (λ (ctc) (or/c-generate (cons (single-or/c-ho-ctc ctc)
+                                              (single-or/c-flat-ctcs ctc))))
+     #:exercise (λ (ctc) (or/c-exercise (list (single-or/c-ho-ctc ctc)))))))
+
+(define-struct (impersonator-single-or/c single-or/c) ()
+  #:property prop:custom-write custom-write-property-proc
+  #:property prop:contract
+  (build-contract-property
+   #:projection single-or/c-projection
+   #:val-first-projection single-or/c-val-first-projection
+   #:name single-or/c-name
+   #:first-order single-or/c-first-order
+   #:stronger single-or/c-stronger?
+   #:generate (λ (ctc) (or/c-generate (cons (single-or/c-ho-ctc ctc)
+                                            (single-or/c-flat-ctcs ctc))))
+   #:exercise (λ (ctc) (or/c-exercise (list (single-or/c-ho-ctc ctc))))))
+
+(define (multi-or/c-proj ctc)
+  (let* ([ho-contracts (multi-or/c-ho-ctcs ctc)]
+         [c-procs (map (λ (x) (contract-projection x)) ho-contracts)]
+         [first-order-checks (map (λ (x) (contract-first-order x)) ho-contracts)]
+         [predicates (map flat-contract-predicate (multi-or/c-flat-ctcs ctc))])
+    (λ (blame)
+      (define disj-blame (blame-add-context blame "a disjunct of"))
+      (define partial-contracts
+        (for/list ([c-proc (in-list c-procs)])
+          (c-proc disj-blame)))
+      (λ (val)
+        (cond
+          [(ormap (λ (pred) (pred val)) predicates)
+           val]
+          [else
+           (let loop ([checks first-order-checks]
+                      [procs partial-contracts]
+                      [contracts ho-contracts]
+                      [candidate-proc #f]
+                      [candidate-contract #f])
+             (cond
+               [(null? checks)
+                (if candidate-proc
+                    (candidate-proc val)
+                    (raise-blame-error blame val 
+                                       '("none of the branches of the or/c matched" given: "~e")
+                                       val))]
+               [((car checks) val)
+                (if candidate-proc
+                    (raise-blame-error blame val
+                                       '("two of the clauses in the or/c might both match: ~s and ~s"
+                                         given:
+                                         "~e")
+                                       (contract-name candidate-contract)
+                                       (contract-name (car contracts))
+                                       val)
+                    (loop (cdr checks)
+                          (cdr procs)
+                          (cdr contracts)
+                          (car procs)
+                          (car contracts)))]
+               [else
+                (loop (cdr checks)
+                      (cdr procs)
+                      (cdr contracts)
+                      candidate-proc
+                      candidate-contract)]))])))))
+
+(define (multi-or/c-val-first-proj ctc)  
+  (define ho-contracts (multi-or/c-ho-ctcs ctc))
+  (define c-projs (map get/build-val-first-projection ho-contracts))
+  (define first-order-checks (map (λ (x) (contract-first-order x)) ho-contracts))
+  (define predicates (map flat-contract-predicate (multi-or/c-flat-ctcs ctc)))
+  (λ (blame)
+    (define blame-w-context (blame-add-or-context blame))
+    (λ (val)
+      (cond
+        [(for/or ([pred (in-list predicates)])
+           (pred val))
+         (λ (neg-party) val)]
+        [else
+         (let loop ([checks first-order-checks]
+                    [c-projs c-projs]
+                    [contracts ho-contracts]
+                    [candidate-c-proj #f]
+                    [candidate-contract #f])
+           (cond
+             [(null? checks)
+              (cond
+                [candidate-c-proj
+                 ((candidate-c-proj blame-w-context) val)]
+                [else
+                 (λ (neg-party)
+                   (raise-blame-error blame val #:missing-party neg-party
+                                      '("none of the branches of the or/c matched" given: "~e")
+                                      val))])]
+             [((car checks) val)
+              (if candidate-c-proj
+                  (λ (neg-party)
+                    (raise-blame-error blame val #:missing-party neg-party
+                                       '("two of the clauses in the or/c might both match: ~s and ~s"
+                                         given:
+                                         "~e")
+                                       (contract-name candidate-contract)
+                                       (contract-name (car contracts))
+                                       val))
+                  (loop (cdr checks)
+                        (cdr c-projs)
+                        (cdr contracts)
+                        (car c-projs)
+                        (car contracts)))]
+             [else
+              (loop (cdr checks)
+                    (cdr c-projs)
+                    (cdr contracts)
+                    candidate-c-proj
+                    candidate-contract)]))]))))
+
+(define (multi-or/c-first-order ctc)
+  (let ([flats (map flat-contract-predicate (multi-or/c-flat-ctcs ctc))]
+        [hos (map (λ (x) (contract-first-order x)) (multi-or/c-ho-ctcs ctc))])
+    (λ (x)
+      (or (ormap (λ (f) (f x)) hos)
+          (ormap (λ (f) (f x)) flats)))))
+
+(define (multi-or/c-stronger? this that)
+  (or (and (multi-or/c? that)
+           (let ([this-ctcs (multi-or/c-ho-ctcs this)]
+                 [that-ctcs (multi-or/c-ho-ctcs that)])
+             (and (= (length this-ctcs) (length that-ctcs))
+                  (andmap contract-stronger? this-ctcs that-ctcs)))
+           (let ([this-ctcs (multi-or/c-flat-ctcs this)]
+                 [that-ctcs (multi-or/c-flat-ctcs that)])
+             (and (= (length this-ctcs) (length that-ctcs))
+                  (andmap contract-stronger? this-ctcs that-ctcs))))
+      (generic-or/c-stronger? this that)))
+
+(define-struct multi-or/c (name flat-ctcs ho-ctcs)
+  #:property prop:orc-contract
+  (λ (this) (append (multi-or/c-ho-ctcs this) 
+                    (multi-or/c-flat-ctcs this))))
+
+(define-struct (chaperone-multi-or/c multi-or/c) ()
+  #:property prop:custom-write custom-write-property-proc
+  #:property prop:chaperone-contract
+  (parameterize ([skip-projection-wrapper? #t])
+    (build-chaperone-contract-property
+     #:projection multi-or/c-proj
+     #:val-first-projection multi-or/c-val-first-proj
+     #:name multi-or/c-name
+     #:first-order multi-or/c-first-order
+     #:stronger multi-or/c-stronger?
+     #:generate (λ (ctc) (or/c-generate (append (multi-or/c-ho-ctcs ctc)
+                                                (multi-or/c-flat-ctcs ctc))))
+     #:exercise (λ (ctc) (or/c-exercise (multi-or/c-ho-ctcs ctc))))))
+
+(define-struct (impersonator-multi-or/c multi-or/c) ()
+  #:property prop:custom-write custom-write-property-proc
+  #:property prop:contract
+  (build-contract-property
+   #:projection multi-or/c-proj
+   #:val-first-projection multi-or/c-val-first-proj
+   #:name multi-or/c-name
+   #:first-order multi-or/c-first-order
+   #:stronger multi-or/c-stronger?
+   #:generate (λ (ctc) (or/c-generate (append (multi-or/c-ho-ctcs ctc)
+                                              (multi-or/c-flat-ctcs ctc))))
+   #:exercise (λ (ctc) (or/c-exercise (multi-or/c-ho-ctcs ctc)))))
+
+(define-struct flat-or/c (pred flat-ctcs)
+  #:property prop:custom-write custom-write-property-proc
+  #:property prop:orc-contract
+  (λ (this) (flat-or/c-flat-ctcs this))
+  #:property prop:flat-contract
+  (build-flat-contract-property
+   #:name
+   (λ (ctc)
+      (apply build-compound-type-name 
+             'or/c 
+             (flat-or/c-flat-ctcs ctc)))
+   #:stronger
+   (λ (this that)
+     (or (and (flat-or/c? that)
+              (let ([this-ctcs (flat-or/c-flat-ctcs this)]
+                    [that-ctcs (flat-or/c-flat-ctcs that)])
+                (cond
+                  [(and (<= (length this-ctcs) (length that-ctcs))
+                        (for/and ([this-ctc (in-list this-ctcs)]
+                                  [that-ctc (in-list that-ctcs)])
+                          (contract-stronger? this-ctc that-ctc)))
+                   #t]
+                  [(and (andmap (λ (x) (or (eq-contract? x) (equal-contract? x))) this-ctcs)
+                        (andmap (λ (x) (or (eq-contract? x) (equal-contract? x))) that-ctcs))
+                   (define ht (make-hash))
+                   (for ([x (in-list that-ctcs)])
+                     (hash-set! ht
+                                (if (equal-contract? x)
+                                    (equal-contract-val x)
+                                    (eq-contract-val x))
+                                #t))
+                   (for/and ([x (in-list this-ctcs)])
+                     (hash-ref ht 
+                               (if (equal-contract? x)
+                                   (equal-contract-val x)
+                                   (eq-contract-val x))
+                               #f))]
+                  [else #f])))
+         (generic-or/c-stronger? this that)))
+                    
+
+   #:first-order
+   (λ (ctc) (flat-or/c-pred ctc))
+   #:generate (λ (ctc) (or/c-generate (flat-or/c-flat-ctcs ctc)))))
+
+
+
+(define/final-prop (symbols s1 . s2s)
+  (define ss (cons s1 s2s))
+  (for ([arg (in-list ss)]
+        [i (in-naturals)])
+    (unless (symbol? arg)
+      (raise-argument-error 'symbols
+                            "symbol?"
+                            i
+                            ss)))
+  (apply or/c ss))
+
+
+
+(define/final-prop (one-of/c . elems)
+  (for ([arg (in-list elems)]
+        [i (in-naturals)])
+    (unless (atomic-value? arg)
+      (raise-argument-error 'one-of/c
+                            "char, symbol, boolean, null, keyword, number, or void"
+                            i
+                            elems)))
+  (define or/c-args
+    (map (λ (x)
+           (cond
+             [(void? x) void?]
+             [else x]))
+         elems))
+  (apply or/c or/c-args))
+
+(define atomic-value? 
+  (λ (x)
+     (or (char? x) (symbol? x) (boolean? x)
+         (null? x) (keyword? x) (number? x)
+         (void? x))))
\ No newline at end of file
diff --git a/racket/collects/racket/contract/private/prop.rkt b/racket/collects/racket/contract/private/prop.rkt
index 01d9e8eda4..b1bababfbd 100644
--- a/racket/collects/racket/contract/private/prop.rkt
+++ b/racket/collects/racket/contract/private/prop.rkt
@@ -36,8 +36,12 @@
          skip-projection-wrapper?
          
          prop:opt-chaperone-contract
-         prop:opt-chaperone-contract? 
-         prop:opt-chaperone-contract-get-test)
+         prop:opt-chaperone-contract?
+         prop:opt-chaperone-contract-get-test
+         
+         prop:orc-contract
+         prop:orc-contract?
+         prop:orc-contract-get-subcontracts)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
@@ -92,9 +96,16 @@
        (get-projection c)))
 
 (define (contract-struct-stronger? a b)
-  (let* ([prop (contract-struct-property a)]
-         [stronger (contract-property-stronger prop)])
-    (stronger a b)))
+  (define prop (contract-struct-property a))
+  (define stronger? (contract-property-stronger prop))
+  (let loop ([b b])
+    (cond
+      [(stronger? a b) #t]
+      [(prop:orc-contract? b)
+       (define sub-contracts ((prop:orc-contract-get-subcontracts b) b))
+       (for/or ([sub-contract (in-list sub-contracts)])
+         (loop sub-contract))]
+      [else #f])))
 
 (define (contract-struct-generate c)
   (define prop (contract-struct-property c))
@@ -398,3 +409,8 @@
   (build-contract make-make-chaperone-contract 'anonymous-chaperone-contract))
 
 (define make-flat-contract (build-contract make-make-flat-contract 'anonymous-flat-contract))
+
+;; property should be bound to a function that accepts the contract and
+;; returns a list of contracts that were the original arguments to the or/c
+(define-values (prop:orc-contract prop:orc-contract? prop:orc-contract-get-subcontracts)
+  (make-struct-type-property 'prop:orc-contract))