diff --git a/collects/mzlib/contract.ss b/collects/mzlib/contract.ss
index 0dc152ed59..0bd6a61af2 100644
--- a/collects/mzlib/contract.ss
+++ b/collects/mzlib/contract.ss
@@ -3,17 +3,27 @@
            "private/contract-arrow.ss"
            "private/contract-guts.ss"
            "private/contract-ds.ss"
+           "private/contract-opt-guts.ss"
            "private/contract-opt.ss"
-           "private/contract-opters.ss" ;; loaded for its effect -- registering the opters
-           )
-  
+           "private/contract-basic-opters.ss")
   
   (provide 
-   ; (all-from "private/contract-opt.ss")  ;; not yet
+   (all-from "private/contract-opt.ss")
+   (all-from "private/contract-opt-guts.ss")
+   (all-from-except "private/contract-opt-guts.ss"
+                    make-opt-contract
+                    orig-ctc-prop
+                    orig-ctc-pred?
+                    orig-ctc-get)
    (all-from "private/contract-ds.ss")
-   (all-from "private/contract-arrow.ss")
+   (all-from-except "private/contract-arrow.ss"
+                    check-procedure)
    (all-from-except "private/contract-guts.ss"
                     build-compound-type-name
                     first-order-prop
-                    first-order-get)
-   (all-from "private/contract.ss")))
+                    first-order-get
+                    check-flat-contract
+                    check-flat-named-contract)
+   (all-from-except "private/contract.ss"
+                    check-between/c
+                    check-unary-between/c)))
\ No newline at end of file
diff --git a/collects/mzlib/private/contract-arrow.ss b/collects/mzlib/private/contract-arrow.ss
index 28ee190b46..504459c3cf 100644
--- a/collects/mzlib/private/contract-arrow.ss
+++ b/collects/mzlib/private/contract-arrow.ss
@@ -2,9 +2,12 @@
   (require (lib "etc.ss")
            (lib "list.ss")
            "contract-guts.ss"
+           "contract-opt.ss"
+           "contract-opt-guts.ss"
            "class-internal.ss")
   
-  (require-for-syntax "contract-helpers.ss"
+  (require-for-syntax "contract-opt-guts.ss"
+                      "contract-helpers.ss"
                       (lib "list.ss")
                       (lib "stx.ss" "syntax")
                       (lib "name.ss" "syntax"))
@@ -25,7 +28,9 @@
            make-mixin-contract
            is-a?/c 
            subclass?/c 
-           implementation?/c)
+           implementation?/c
+           
+           check-procedure)
   
   
   (define-syntax (any stx)
@@ -1738,6 +1743,113 @@
                            (void)]
                           [else (loop (cdr counts))]))))
                   (<= min-at-least dom-length))))])))
+  
+  ;;
+  ;; arrow opter
+  ;;
+  (define/opter (-> opt/i pos neg stx)
+    (define (opt/arrow-ctc doms rngs)
+      (let*-values ([(dom-vars rng-vars) (values (generate-temporaries doms)
+                                                 (generate-temporaries rngs))]
+                    [(next-doms lifts-doms partials-doms)
+                     (let loop ([vars dom-vars]
+                                [doms doms]
+                                [next-doms null]
+                                [lifts-doms null]
+                                [partials-doms null])
+                       (cond
+                         [(null? doms) (values (reverse next-doms) lifts-doms partials-doms)]
+                         [else
+                          (let-values ([(next lift partial _ __)
+                                        (opt/i neg pos (car doms))])
+                            (loop (cdr vars)
+                                  (cdr doms)
+                                  (cons (with-syntax ((next next)
+                                                      (car-vars (car vars)))
+                                          (syntax (let ((val car-vars)) next)))
+                                        next-doms)
+                                  (append lifts-doms lift)
+                                  (append partials-doms partial)))]))]
+                    [(next-rngs lifts-rngs partials-rngs)
+                     (let loop ([vars rng-vars]
+                                [rngs rngs]
+                                [next-rngs null]
+                                [lifts-rngs null]
+                                [partials-rngs null])
+                       (cond
+                         [(null? rngs) (values (reverse next-rngs) lifts-rngs partials-rngs)]
+                         [else
+                          (let-values ([(next lift partial _ __)
+                                        (opt/i pos neg (car rngs))])
+                            (loop (cdr vars)
+                                  (cdr rngs)
+                                  (cons (with-syntax ((next next)
+                                                      (car-vars (car vars)))
+                                          (syntax (let ((val car-vars)) next)))
+                                        next-rngs)
+                                  (append lifts-rngs lift)
+                                  (append partials-rngs partial)))]))])
+        (values
+         (with-syntax ((pos pos)
+                       ((dom-arg ...) dom-vars)
+                       ((rng-arg ...) rng-vars)
+                       ((next-dom ...) next-doms)
+                       (dom-len (length dom-vars))
+                       ((next-rng ...) next-rngs))
+           (syntax (begin
+                     (check-procedure val dom-len src-info pos orig-str)
+                     (λ (dom-arg ...)
+                       (let-values ([(rng-arg ...) (val next-dom ...)])
+                         (values next-rng ...))))))
+         (append lifts-doms lifts-rngs)
+         (append partials-doms partials-rngs)
+         #f
+         #f)))
+    
+    (define (opt/arrow-any-ctc doms)
+      (let*-values ([(dom-vars) (generate-temporaries doms)]
+                    [(next-doms lifts-doms partials-doms)
+                     (let loop ([vars dom-vars]
+                                [doms doms]
+                                [next-doms null]
+                                [lifts-doms null]
+                                [partials-doms null])
+                       (cond
+                         [(null? doms) (values (reverse next-doms) lifts-doms partials-doms)]
+                         [else
+                          (let-values ([(next lift partial flat _)
+                                        (opt/i pos neg (car doms))])
+                            (loop (cdr vars)
+                                  (cdr doms)
+                                  (cons (with-syntax ((next next)
+                                                      (car-vars (car vars)))
+                                          (syntax (let ((val car-vars)) next)))
+                                        next-doms)
+                                  (append lifts-doms lift)
+                                  (append partials-doms partial)))]))])
+        (values
+         (with-syntax ((pos pos)
+                       ((dom-arg ...) dom-vars)
+                       ((next-dom ...) next-doms)
+                       (dom-len (length dom-vars)))
+           (syntax (begin
+                     (check-procedure val dom-len src-info pos orig-str)
+                     (λ (dom-arg ...)
+                       (val next-dom ...)))))
+         lifts-doms
+         partials-doms
+         #f
+         #f)))
+    
+    (syntax-case stx (-> values any)
+      [(-> dom ... (values rng ...))
+       (opt/arrow-ctc (syntax->list (syntax (dom ...)))
+                      (syntax->list (syntax (rng ...))))]
+      [(-> dom ... any)
+       (opt/arrow-any-ctc (syntax->list (syntax (dom ...))))]
+      [(-> dom ... rng)
+       (opt/arrow-ctc (syntax->list (syntax (dom ...)))
+                      (list #'rng))]))
 
   ;; ----------------------------------------
   ;; Checks and error functions used in macro expansions
diff --git a/collects/mzlib/private/contract-basic-opters.ss b/collects/mzlib/private/contract-basic-opters.ss
new file mode 100644
index 0000000000..0a8901af40
--- /dev/null
+++ b/collects/mzlib/private/contract-basic-opters.ss
@@ -0,0 +1,144 @@
+(module contract-basic-opters mzscheme
+  (require "contract-guts.ss"
+           "contract-opt.ss")
+  (require-for-syntax "contract-opt-guts.ss")
+  
+  ;;
+  ;; opt/pred helper
+  ;;
+  (define-for-syntax (opt/pred pos pred)
+    (let* ((lift-vars (generate-temporaries (syntax (pred))))
+           (lift-pred-var (car lift-vars)))
+      (with-syntax ((lift-pred lift-pred-var))
+        (values
+         (with-syntax ((pos pos))
+           (syntax (if (lift-pred val)
+                       val
+                       (raise-contract-error
+                        val
+                        src-info
+                        pos
+                        orig-str
+                        "expected <~a>, given: ~e"
+                        ((name-get ctc) ctc)
+                        val))))
+         (list (cons lift-pred-var pred))
+         null
+         (syntax (lift-pred val))
+         #f))))
+  
+  ;;
+  ;; built-in predicate opters
+  ;;
+  (define/opter (null? opt/i pos neg stx)
+    (syntax-case stx (null?)
+      [null? (opt/pred pos #'null?)]))
+  (define/opter (boolean? opt/i pos neg stx)
+    (syntax-case stx (boolean?)
+      [boolean? (opt/pred pos #'boolean?)]))
+  (define/opter (integer? opt/i pos neg stx)
+    (syntax-case stx (integer?)
+      [integer? (opt/pred pos #'integer?)]))
+  (define/opter (number? opt/i pos neg stx)
+    (syntax-case stx (number?)
+      [number? (opt/pred pos #'number?)]))
+  (define/opter (pair? opt/i pos neg stx)
+    (syntax-case stx (pair?)
+      [pair? (opt/pred pos #'pair?)]))
+  
+  ;;
+  ;; any/c
+  ;;
+  (define/opter (any/c opt/i pos neg stx)
+    (syntax-case stx (any/c)
+      [any/c (values
+              #'val
+              null
+              null
+              #'#t
+              #f)]))
+
+  ;;
+  ;; flat-contract helper
+  ;;
+  (define-for-syntax (opt/flat-ctc pos pred checker)
+    (syntax-case pred (null? number? integer? boolean? pair?)
+      ;; Better way of doing this?
+      [null? (opt/pred pos pred)]
+      [number? (opt/pred pos pred)]
+      [integer? (opt/pred pos pred)]
+      [boolean? (opt/pred pos pred)]
+      [pair? (opt/pred pos pred)]
+      [pred
+       (let* ((lift-vars (generate-temporaries (syntax (pred error-check))))
+              (lift-pred (car lift-vars)))
+         (with-syntax ((pos pos)
+                       (lift-pred lift-pred))
+           (values
+            (syntax (if (lift-pred val)
+                        val
+                        (raise-contract-error
+                         val
+                         src-info
+                         pos
+                         orig-str
+                         "expected <~a>, given: ~e"
+                         ((name-get ctc) ctc)
+                         val)))
+            (interleave-lifts
+             lift-vars
+             (list #'pred (cond [(eq? checker 'check-flat-contract) #'(check-flat-contract lift-pred)]
+                                [(eq? checker 'check-flat-named-contract) #'(check-flat-named-contract lift-pred)])))
+            null
+            (syntax (lift-pred val))
+            #f)))]))
+  
+  ;;
+  ;; flat-contract and friends
+  ;;
+  (define/opter (flat-contract opt/i pos neg stx)
+    (syntax-case stx (flat-contract)
+      [(flat-contract pred) (opt/flat-ctc pos #'pred 'check-flat-contract)]))
+  (define/opter (flat-named-contract opt/i pos neg stx)
+    (syntax-case stx (flat-named-contract)
+      [(flat-named-contract name pred) (opt/flat-ctc pos #'pred 'check-flat-named-contract)]))
+  
+  ;;
+  ;; unknown
+  ;;
+  ;; BUGS: currently, opt/c reports error on something like
+  ;;       (opt/c (or/c (begin (print "side effect") number?) boolean?))
+  ;;       because the begin sequence is unrecognized, and we have no idea of
+  ;;       knowing that `number?' is a pred that we can opt.
+  ;; WORKAROUND: wrap `flat-contract' around the pred, it optimizes to the same
+  ;;             thing.
+  ;;
+  (define/opter (unknown opt/i pos neg stx)
+    (define (opt/unknown-ctc uctc)
+      (let* ((lift-vars (generate-temporaries (syntax (lift error-check))))
+             (lift-var (car lift-vars))
+             (partial-var (car (generate-temporaries (syntax (partial))))))
+        (values
+         (with-syntax ((partial-var partial-var)
+                       (lift-var lift-var)
+                       (uctc uctc))
+           (syntax (partial-var val)))
+         (interleave-lifts
+          lift-vars
+          (list uctc
+                (with-syntax ((lift-var lift-var))
+                  (syntax
+                   (unless (contract? lift-var)
+                     (error 'contract "expected contract, given ~e" lift-var))))))
+         (list (cons
+                partial-var
+                (with-syntax ((lift-var lift-var)
+                              (pos pos)
+                              (neg neg))
+                  (syntax (((proj-get lift-var) lift-var) pos neg src-info orig-str)))))
+         #f
+         lift-var)))
+    
+    (syntax-case stx ()
+      [ctc
+       (opt/unknown-ctc #'ctc)])))
\ No newline at end of file
diff --git a/collects/mzlib/private/contract-guts.ss b/collects/mzlib/private/contract-guts.ss
index 9f0d24ea05..ef82e96bc0 100644
--- a/collects/mzlib/private/contract-guts.ss
+++ b/collects/mzlib/private/contract-guts.ss
@@ -40,7 +40,11 @@
            flat-prop flat-pred? flat-get
            flat-proj
            first-order-prop
-           first-order-get)
+           first-order-get
+           
+           ;; for opters
+           check-flat-contract
+           check-flat-named-contract)
   
 
   ;; define-struct/prop is a define-struct-like macro that
@@ -313,23 +317,26 @@
   (define (contract? x) (proj-pred? x))
   (define (contract-proc ctc) ((proj-get ctc) ctc))
   
-  (define (flat-contract predicate)
+  (define (check-flat-contract predicate)
     (unless (and (procedure? predicate)
                  (procedure-arity-includes? predicate 1))
       (error 'flat-contract
-             "expected procedure of one argument as argument, given ~e"
-             predicate))
+             "expected procedure of arity 1 as argument, given ~e"
+             predicate)))
+  (define (flat-contract predicate)
+    (check-flat-contract predicate)
     (let ([pname (object-name predicate)])
       (if pname
           (flat-named-contract pname predicate)
           (flat-named-contract '??? predicate))))
-  
-  (define (flat-named-contract name predicate)
+  (define (check-flat-named-contract predicate)
     (unless (and (procedure? predicate)
                  (procedure-arity-includes? predicate 1))
       (error 'flat-named-contract
-             "expected procedure of one argument as second argument, given: ~e, fst arg ~e"
-             predicate name))
+             "expected procedure of arity 1 as second argument, given ~e"
+             predicate)))
+  (define (flat-named-contract name predicate)
+    (check-flat-named-contract predicate)
     (build-flat-contract name predicate))
   
   (define (build-flat-contract name predicate) (make-flat-contract name predicate))
diff --git a/collects/mzlib/private/contract-opt-guts.ss b/collects/mzlib/private/contract-opt-guts.ss
index bbdd3e34a1..873db4f4c7 100644
--- a/collects/mzlib/private/contract-opt-guts.ss
+++ b/collects/mzlib/private/contract-opt-guts.ss
@@ -1,15 +1,31 @@
 (module contract-opt-guts mzscheme
-  (require "contract.ss"
-           "contract-guts.ss"
-           "contract-arrow.ss")
+  (require "contract-guts.ss")
   
-  (provide make-known known? known-flag known-sexp
-           get-opter reg-opter! opter
-           make-lifted interleave-lifted)
+  (provide get-opter reg-opter! opter
+           
+           make-opt-contract
+           orig-ctc-prop orig-ctc-pred? orig-ctc-get
+
+           make-lifts interleave-lifts)
   
-  (define-struct known (flag sexp))
+  (define-values (orig-ctc-prop orig-ctc-pred? orig-ctc-get)
+    (make-struct-type-property 'original-contract))
   
-  ;; State information for opters
+  ;; optimized contracts
+  ;;
+  ;; getting the name of an optimized contract is slow, but it is only
+  ;; called when blame is raised (thankfully).
+  ;;
+  ;; note that lifts, partials, flat, and unknown are all built into the
+  ;; projection itself and should not be exposed to the outside anyhow.
+  (define-struct/prop opt-contract (proj orig-ctc)
+    ((proj-prop (λ (ctc) ((opt-contract-proj ctc) ctc)))
+     (name-prop (λ (ctc) ((name-get ((orig-ctc-get ctc) ctc)) ((orig-ctc-get ctc) ctc))))
+     (orig-ctc-prop (λ (ctc) ((opt-contract-orig-ctc ctc))))
+     (stronger-prop (λ (this that)
+                      #f)))) ;; TODO, how to do this?
+
+  ;; a hash table of opters
   (define opters-table
     (make-hash-table 'equal))
   
@@ -17,7 +33,7 @@
   (define (get-opter ctc)
     (hash-table-get opters-table ctc #f))
   
-  ;; opter : syntax or symbol -> opter
+  ;; opter : (union symbol identifier) -> opter
   (define (opter ctc)
     (if (or (identifier? ctc) (symbol? ctc))
         (let ((key (if (syntax? ctc) (syntax-e ctc) ctc)))
@@ -28,20 +44,20 @@
   (define (reg-opter! ctc opter)
     (hash-table-put! opters-table ctc opter))
   
-  ;; make-lifted : list -> syntax
+  ;; make-lifts : list -> syntax
   ;; converts a list of lifted-var lifted-expr pairs into a syntax object
   ;; suitable for use in a let.
-  (define (make-lifted lst)
+  (define (make-lifts lst)
     (map (λ (x) (with-syntax ((var (car x))
                               (e (cdr x)))
                   (syntax (var e)))) lst))
   
-  ;; interleave-lifted : list list -> list
+  ;; interleave-lifts : list list -> list
   ;; interleaves a list of variables names and a list of sexps into a list of
-  ;; (var sexp) pairs
-  (define (interleave-lifted vars sexps)
+  ;; (var sexp) pairs.
+  (define (interleave-lifts vars sexps)
     (if (= (length vars) (length sexps))
         (if (null? vars) null
             (cons (cons (car vars) (car sexps))
-                  (interleave-lifted (cdr vars) (cdr sexps))))
-        (error 'interleave-lifted "expected lists of equal length, got ~e and ~e" vars sexps))))
+                  (interleave-lifts (cdr vars) (cdr sexps))))
+        (error 'interleave-lifts "expected lists of equal length, got ~e and ~e" vars sexps))))
\ No newline at end of file
diff --git a/collects/mzlib/private/contract-opt.ss b/collects/mzlib/private/contract-opt.ss
index fcf3333475..4c74f9d725 100644
--- a/collects/mzlib/private/contract-opt.ss
+++ b/collects/mzlib/private/contract-opt.ss
@@ -1,13 +1,35 @@
 (module contract-opt mzscheme
-  (require "contract.ss"
-           "contract-guts.ss"
-           "contract-arrow.ss")
+  (require "contract-guts.ss"
+           "contract-opt-guts.ss")
   (require-for-syntax "contract-opt-guts.ss"
                       (lib "list.ss"))
   
   (provide opt/c define/opter)
   
-  ;; TODO document this
+  ;; define/opter : id -> syntax
+  ;;
+  ;; Takes an expression which is to be expected of the following signature: 
+  ;;
+  ;; opter : id id syntax ->
+  ;;         syntax syntax-list syntax-list (union syntax #f) (union syntax #f)
+  ;;
+  ;; It takes in an identifier for pos, neg, and the original syntax. An identifier
+  ;; that can be used to call the opt/i function is also implicitly passed into
+  ;; every opter.
+  ;;
+  ;; Every opter needs to return:
+  ;;  - the optimized syntax
+  ;;  - lifted variables: a list of (id, sexp) pairs
+  ;;  - partially applied contracts: a list of (id, sexp) pairs
+  ;;  - if the contract being optimized is flat,
+  ;;    then an sexp that evals to bool,
+  ;;    else #f
+  ;;    This is used in conjunction with optimizing flat contracts into one boolean
+  ;;    expression when optimizing or/c.
+  ;;  - if the contract can be optimized,
+  ;;    then #f (that is, it is not unknown)
+  ;;    else the symbol of the lifted variable
+  ;;    This is used for contracts with subcontracts (like cons) doing checks.
   (define-syntax (define/opter stx)
     (syntax-case stx ()
       [(_ (for opt/i pos neg stx) expr ...)
@@ -22,21 +44,20 @@
            (error 'define/opter "expected opter name to be an identifier, got ~e" (syntax-e #'for)))]))
   
   ;; opt/c : syntax -> syntax
-  ;; opt is an optimization routine that takes in an s-expression containing
+  ;; opt/c is an optimization routine that takes in an sexp containing
   ;; contract combinators and attempts to "unroll" those combinators to save
   ;; on things such as closure allocation time.
   (define-syntax (opt/c stx)
     
-    ;; opt/i : syntax syntax syntax -> syntax list-of-syntax list-of-syntax boolean-or-syntax known
+    ;; opt/i : id id syntax ->
+    ;;         syntax syntax-list syntax-list (union syntax #f) (union syntax #f)
     (define (opt/i pos neg stx)
       (syntax-case stx ()
         [(ctc arg ...)
          (and (identifier? #'ctc) (opter #'ctc))
-         (begin
-           ((opter #'ctc) opt/i pos neg stx))]
+         ((opter #'ctc) opt/i pos neg stx)]
         [argless-ctc
          (and (identifier? #'argless-ctc) (opter #'argless-ctc))
-         ;; FIXME computes pred? twice
          ((opter #'argless-ctc) opt/i pos neg stx)]
         [else
          (if (opter 'unknown)
@@ -45,15 +66,15 @@
     
     (syntax-case stx ()
       [(_ e)
-       (let-values ([(next lifted partials _ __) (opt/i #'pos #'neg #'e)])
+       (let-values ([(next lifts partials _ __) (opt/i #'pos #'neg #'e)])
          (with-syntax ((next next)
-                       (lifted (make-lifted lifted))
-                       (partials (make-lifted partials)))
-           (syntax (let* lifted
-                     (make-proj-contract
-                      contract-name
-                      (λ (pos neg src-info orig-str)
-                        (let partials
-                          (λ (val)
-                            next)))
-                      #f)))))])))
\ No newline at end of file
+                       (lifts (make-lifts lifts))
+                       (partials (make-lifts partials))
+                       (stx stx)) 
+           (syntax (make-opt-contract
+                    (λ (ctc)
+                      (let* lifts
+                        (λ (pos neg src-info orig-str)
+                          (let partials
+                            (λ (val) next)))))
+                    (λ () e)))))])))
\ No newline at end of file
diff --git a/collects/mzlib/private/contract-opters.ss b/collects/mzlib/private/contract-opters.ss
deleted file mode 100644
index 783c10a36d..0000000000
--- a/collects/mzlib/private/contract-opters.ss
+++ /dev/null
@@ -1,494 +0,0 @@
-(module contract-opters mzscheme
-  (require "contract.ss"
-           "contract-guts.ss"
-           "contract-arrow.ss"
-           "contract-opt.ss")
-  (require-for-syntax "contract-opt-guts.ss")
-  
-  ;; opt/between-ctc : syntax syntax syntax -> syntax list-of-syntax list-of-syntax boolean-or-syntax known
-  (define-for-syntax (opt/between-ctc pos stx low high op)
-    (let* ((lifted-vars (generate-temporaries (syntax (low high error-check))))
-           (lifted-low (car lifted-vars))
-           (lifted-high (cadr lifted-vars)))
-      (with-syntax ((op op)
-                    (n lifted-low)
-                    (m lifted-high))
-        (values
-         (with-syntax ((pos pos))
-           (syntax (if (and (number? val) (op n val m)) val
-                       (raise-contract-error
-                        val
-                        src-info
-                        pos
-                        orig-str
-                        "expected <~a>, given: ~e"
-                        contract-name
-                        val))))
-         (append (interleave-lifted
-                  lifted-vars
-                  (list low
-                        high
-                        (syntax (unless (and (number? n) (number? m))
-                                  (error 'between/c "expected two numbers for bounds, got ~e and ~e" n m)))))
-                 (list (cons #'contract-name (syntax (cond
-                                                       [(= n -inf.0) `(<=/c ,m)]
-                                                       [(= m +inf.0) `(>=/c ,n)]
-                                                       [(= n m) `(=/c ,n)]
-                                                       [else `(between/c ,n ,m)])))))
-         null
-         (syntax (and (number? val) (op n val m)))
-         (make-known #t stx)))))
-  
-  (define/opter (between/c opt/i pos neg stx)
-    (syntax-case stx (between/c)
-      [(between/c low high) (opt/between-ctc pos stx #'low #'high #'<=)]))
-  
-  (define/opter (>/c opt/i pos neg stx)
-    (syntax-case stx (>/c)
-      [(>/c low) (opt/between-ctc #'low #'+inf.0 #'<)]))
-  
-  (define/opter (>=/c opt/i pos neg stx)
-    (syntax-case stx (>/c)
-      [(>=/c low) (opt/between-ctc #'low #'+inf.0 #'<=)]))
-  
-  (define/opter (</c opt/i pos neg stx)
-    (syntax-case stx (>/c)
-      [(</c high) (opt/between-ctc #'-inf.0 #'high #'<)]))
-  
-  (define/opter (<=/c opt/i pos neg stx)
-    (syntax-case stx (>/c)
-      [(<=/c high) (opt/between-ctc #'-inf.0 #'high #'<=)]))
-  
-  (define/opter (cons-immutable/c opt/i pos neg stx)
-    
-    ;; opt/cons-immutable-ctc : syntax syntax -> syntax list-of-syntax list-of-syntax boolean-or-syntax known
-    (define (opt/cons-immutable-ctc hdp tlp)
-      (let-values ([(next-hdp lifted-hdp partial-hdp flat?-hdp known?-hdp)
-                    (opt/i pos neg hdp)]
-                   [(next-tlp lifted-tlp partial-tlp flat?-tlp known?-tlp)
-                    (opt/i pos neg tlp)]
-                   [(error-check)
-                    (car (generate-temporaries (syntax (error-check))))])
-        (with-syntax ((check (syntax (and (immutable? val)
-                                          (pair? val)))))
-          (values
-           (with-syntax ((pos pos)
-                         (next-hdp next-hdp)
-                         (next-tlp next-tlp))
-             (syntax (if check
-                         (cons-immutable (let ((val (car val))) next-hdp)
-                                         (let ((val (cdr val))) next-tlp))
-                         (raise-contract-error
-                          val
-                          src-info
-                          pos
-                          orig-str
-                          "expected <~a>, given: ~e"
-                          contract-name
-                          val))))
-           (append
-            (append lifted-hdp lifted-tlp)
-            ;; FIXME naming still broken
-            (list (cons #'contract-name
-                        #''cons-immutable/c)))
-           (append partial-hdp partial-tlp)
-           (if (and flat?-hdp flat?-tlp)
-               (with-syntax ((flat-hdp flat?-hdp)
-                             (flat-tlp flat?-tlp))
-                 (syntax (if (and check
-                                  (let ((val (car val))) flat-hdp)
-                                  (let ((val (cdr val))) flat-tlp)) #t #f)))
-               #f)
-           (make-known #t stx)))))
-    
-    (syntax-case stx (cons-immutable/c)
-      [(cons-immutable/c hdp tlp)
-       (opt/cons-immutable-ctc #'hdp #'tlp)]))
-  
-  (define/opter (cons/c opt/i pos neg stx)
-    
-    ;; opt/cons-ctc : syntax syntax -> syntax list-of-syntax list-of-syntax boolean-or-syntax known
-    (define (opt/cons-ctc hdp tlp)
-      (let-values ([(next-hdp lifted-hdp partial-hdp flat?-hdp known-hdp)
-                    (opt/i pos neg hdp)]
-                   [(next-tlp lifted-tlp partial-tlp flat?-tlp known-tlp)
-                    (opt/i pos neg tlp)]
-                   [(error-check)
-                    (car (generate-temporaries (syntax (error-check))))])
-        (with-syntax ((next 
-                       (with-syntax ((flat?-hdp flat?-hdp)
-                                     (flat?-tlp flat?-tlp))
-                         (syntax
-                          (and (pair? val)
-                               (let ((val (car val))) flat?-hdp)
-                               (let ((val (cdr val))) flat?-tlp))))))
-          (values
-           (with-syntax ((pos pos))
-             (syntax (if next
-                         val
-                         (raise-contract-error
-                          val
-                          src-info
-                          pos
-                          orig-str
-                          "expected <~a>, given: ~e"
-                          contract-name
-                          val))))
-           (append
-            lifted-hdp lifted-tlp
-            (list (cons error-check
-                        (with-syntax ((hdp (known-sexp known-hdp))
-                                      (tlp (known-sexp known-tlp))
-                                      (check (with-syntax ((flat-hdp
-                                                            (cond
-                                                              [(known-flag known-hdp)
-                                                               (if flat?-hdp #'#t #'#f)]
-                                                              [else (with-syntax ((ctc (known-sexp known-hdp)))
-                                                                      (syntax (flat-contract? ctc)))]))
-                                                           (flat-tlp
-                                                            (cond
-                                                              [(known-flag known-tlp)
-                                                               (if flat?-tlp #'#t #'#f)]
-                                                              [else (with-syntax ((ctct (known-sexp known-tlp)))
-                                                                      (syntax (flat-contract? ctc)))])))
-                                               (syntax (and flat-hdp flat-tlp)))))
-                          (syntax
-                           (unless check
-                             (error 'cons/c "expected two flat contracts or procedures of arity 1, got: ~e and ~e"
-                                    hdp tlp))))))
-            ;; FIXME naming still broken
-            (list (cons #'contract-name
-                        #''cons/c)))
-           (append partial-hdp partial-tlp)
-           (syntax (if next #t #f))
-           (make-known #t stx)))))
-    
-    (syntax-case stx (cons/c)
-      [(cons/c hdp tlp)
-       (opt/cons-ctc #'hdp #'tlp)]))
-  
-  ;; opt/pred-ctc : (any -> boolean) -> syntax list-of-syntax list-of-syntax boolean-or-syntax known
-  (define-for-syntax (opt/pred pos pred)
-    (let* ((lifted-vars (generate-temporaries (syntax (pred))))
-           (lifted-pred-var (car lifted-vars)))
-      (with-syntax ((lifted-pred lifted-pred-var))
-        (values
-         (with-syntax ((pos pos))
-           (syntax (if (lifted-pred val)
-                       val
-                       (raise-contract-error
-                        val
-                        src-info
-                        pos
-                        orig-str
-                        "expected <~a>, given: ~e"
-                        contract-name
-                        val))))
-         (append (list (cons lifted-pred-var pred))
-                 #;(list (cons #'contract-name (syntax
-                                                (if (object-name pred)
-                                                    (object-name pred)
-                                                    '???)))))
-         null
-         (syntax (lifted-pred val))
-         (make-known #t pred)))))
-  
-  (define/opter (null? opt/i pos neg stx)
-    (syntax-case stx (null?)
-      [null? (opt/pred pos #'null?)]))
-  
-  (define/opter (boolean? opt/i pos neg stx)
-    (syntax-case stx (boolean?)
-      [boolean? (opt/pred pos #'boolean?)]))
-  
-  (define/opter (integer? opt/i pos neg stx)
-    (syntax-case stx (integer?)
-      [integer? (opt/pred pos #'integer?)]))
-  
-  (define/opter (number? opt/i pos neg stx)
-    (syntax-case stx (number?)
-      [number? (opt/pred pos #'number?)]))
-  
-  (define/opter (pair? opt/i pos neg stx)
-    (syntax-case stx (pair?)
-      [pair? (opt/pred pos #'pair?)]))
-  
-  (define/opter (any/c opt/i pos neg stx)
-    
-    ;; opt/any-ctc : -> syntax list-of-syntax list-of-syntax boolean-or-syntax known
-    (define opt/any-ctc
-      (values
-       #'val
-       (list (cons #'contract-name
-                   #''any/c))
-       null
-       (syntax #t)
-       (make-known #t stx)))
-    
-    (syntax-case stx (any/c)
-      [any/c opt/any-ctc]))
-  
-  (define/opter (flat-contract opt/i pos neg stx)
-    
-    ;; opt/flat-ctc : (any -> boolean) -> syntax list-of-syntax list-of-syntax boolean-or-syntax known
-    (define (opt/flat-ctc pred)
-      (syntax-case pred (null? number? integer? boolean? pair?)
-        ;; Better way of doing this?
-        [null? (opt/pred pos pred)]
-        [number? (opt/pred pos pred)]
-        [integer? (opt/pred pos pred)]
-        [boolean? (opt/pred pos pred)]
-        [pair? (opt/pred pos pred)]
-        [pred
-         (let* ((lifted-vars (generate-temporaries (syntax (pred error-check))))
-                (lifted-pred (car lifted-vars)))
-           (with-syntax ((lifted-pred (car lifted-vars)))
-             (values
-              (with-syntax ((pos pos))
-                (syntax (if (lifted-pred val)
-                            val
-                            (raise-contract-error
-                             val
-                             src-info
-                             pos
-                             orig-str
-                             "expected <~a>, given: ~e"
-                             contract-name
-                             val))))
-              (append (interleave-lifted
-                       lifted-vars
-                       (list #'pred
-                             (syntax (unless (and (procedure? lifted-pred)
-                                                  (procedure-arity-includes? lifted-pred 1))
-                                       (error 'flat-named-contract
-                                              "expected procedure of one argument, given: ~e" lifted-pred)))))
-                      (list (cons #'contract-name (syntax
-                                                   (if (object-name pred)
-                                                       (object-name pred)
-                                                       '???)))))
-              null
-              (syntax (lifted-pred val))
-              (make-known #t stx))))]))
-    
-    (syntax-case stx (flat-contract)
-      [(flat-contract pred)
-       (opt/flat-ctc #'pred)]))
-  
-  (define/opter (-> opt/i pos neg stx)
-    
-    ;; opt/arrow-ctc : list-of-syntax list-of-syntax -> syntax list-of-syntax list-of-syntax boolean-or-syntax known
-    (define (opt/arrow-ctc doms rngs)
-      (let*-values ([(dom-vars rng-vars) (values (generate-temporaries doms)
-                                                 (generate-temporaries rngs))]
-                    [(next-doms lifted-doms partial-doms)
-                     (let loop ([vars dom-vars]
-                                [doms doms]
-                                [next-doms null]
-                                [lifted-doms null]
-                                [partial-doms null])
-                       (cond
-                         [(null? doms) (values (reverse next-doms) lifted-doms partial-doms)]
-                         [else
-                          (let-values ([(next lifted partial flat? _)
-                                        (opt/i neg pos (car doms))])
-                            (loop (cdr vars)
-                                  (cdr doms)
-                                  (cons (with-syntax ((next next)
-                                                      (car-vars (car vars)))
-                                          (syntax (let ((val car-vars)) next)))
-                                        next-doms)
-                                  (append lifted-doms lifted)
-                                  (append partial-doms partial)))]))]
-                    [(next-rngs lifted-rngs partial-rngs)
-                     (let loop ([vars rng-vars]
-                                [rngs rngs]
-                                [next-rngs null]
-                                [lifted-rngs null]
-                                [partial-rngs null])
-                       (cond
-                         [(null? rngs) (values (reverse next-rngs) lifted-rngs partial-rngs)]
-                         [else
-                          (let-values ([(next lifted partial flat? _)
-                                        (opt/i pos neg (car rngs))])
-                            (loop (cdr vars)
-                                  (cdr rngs)
-                                  (cons (with-syntax ((next next)
-                                                      (car-vars (car vars)))
-                                          (syntax (let ((val car-vars)) next)))
-                                        next-rngs)
-                                  (append lifted-rngs lifted)
-                                  (append partial-rngs partial)))]))])
-        (values
-         (with-syntax (((dom-arg ...) dom-vars)
-                       ((rng-arg ...) rng-vars)
-                       ((next-dom ...) next-doms)
-                       (dom-len (length dom-vars))
-                       ((next-rng ...) next-rngs))
-           (syntax (if (and (procedure? val) (procedure-arity-includes? val dom-len))
-                       (λ (dom-arg ...)
-                         (let-values ([(rng-arg ...) (val next-dom ...)])
-                           (values next-rng ...)))
-                       (error '-> "expected a procedure of arity ~a, got ~e" dom-len val))))
-         (append lifted-doms lifted-rngs
-                 (list (cons #'contract-name
-                             #''->/c)))
-         (append partial-doms partial-rngs)
-         #f
-         (make-known #t stx))))
-    
-    ;; opt/arrow-any-ctc : list-of-syntax -> syntax list-of-syntax list-of-syntax boolean-or-syntax known
-    (define (opt/arrow-any-ctc doms)
-      (let*-values ([(dom-vars) (generate-temporaries doms)]
-                    [(next-doms lifted-doms partial-doms)
-                     (let loop ([vars dom-vars]
-                                [doms doms]
-                                [next-doms null]
-                                [lifted-doms null]
-                                [partial-doms null])
-                       (cond
-                         [(null? doms) (values (reverse next-doms) lifted-doms partial-doms)]
-                         [else
-                          (let-values ([(next lifted partial flat? _)
-                                        (opt/i pos neg (car doms))])
-                            (loop (cdr vars)
-                                  (cdr doms)
-                                  (cons (with-syntax ((next next)
-                                                      (car-vars (car vars)))
-                                          (syntax (let ((val car-vars)) next)))
-                                        next-doms)
-                                  (append lifted-doms lifted)
-                                  (append partial-doms partial)))]))])
-        (values
-         (with-syntax (((dom-arg ...) dom-vars)
-                       ((next-dom ...) next-doms)
-                       (dom-len (length dom-vars)))
-           (syntax (if (and (procedure? val) (procedure-arity-includes? val dom-len))
-                       (λ (dom-arg ...)
-                         (val next-dom ...))
-                       (error '-> "expected a procedure of arity ~a, got ~e" dom-len val))))
-         (append lifted-doms
-                 ;; FIXME naming still broken
-                 (list (cons #'contract-name
-                             #''->/c)))
-         (append partial-doms)
-         #f
-         (make-known #t stx))))
-    
-    (syntax-case stx (-> values any)
-      [(-> dom ... (values rng ...))
-       (opt/arrow-ctc (syntax->list (syntax (dom ...)))
-                      (syntax->list (syntax (rng ...))))]
-      [(-> dom ... any)
-       (opt/arrow-any-ctc (syntax->list (syntax (dom ...))))]
-      [(-> dom ... rng)
-       (opt/arrow-ctc (syntax->list (syntax (dom ...)))
-                      (list #'rng))]))
-  
-  (define/opter (unknown opt/i pos neg stx)
-    
-    ;; opt/unknown-ctc : list-of-syntax -> syntax list-of-syntax list-of-syntax boolean-or-syntax known
-    (define (opt/unknown-ctc ctc)
-      (let* ((lifted-vars (generate-temporaries (syntax (lifted error-check))))
-             (lifted-var (car lifted-vars))
-             (partial-var (car (generate-temporaries (syntax (partial))))))
-        (values
-         (with-syntax ((partial-var partial-var)
-                       (lifted-var lifted-var)
-                       (ctc ctc))
-           (syntax (partial-var val)))
-         (append
-          (interleave-lifted
-           lifted-vars
-           (list ctc
-                 (with-syntax ((lifted-var lifted-var))
-                   (syntax
-                    (unless (contract? lifted-var)
-                      (error 'contract "expected contract, given ~e" lifted-var))))))
-          (list
-           (cons #'contract-name
-                 #''opt/c)))
-         (list (cons
-                partial-var
-                (with-syntax ((lifted-var lifted-var)
-                              (pos pos)
-                              (neg neg))
-                  (syntax (((proj-get lifted-var) lifted-var) pos neg src-info orig-str)))))
-         #f
-         (make-known #f lifted-var))))
-    
-    (syntax-case stx ()
-      [ctc
-       (opt/unknown-ctc #'ctc)]))
-  
-  (define/opter (or/c opt/i pos neg stx)
-    
-    ;; opt/or-ctc : list-of-syntax -> syntax list-of-syntax list-of-syntax boolean-or-syntax known
-    (define (opt/or-ctc ps)  
-      (let ((lifted-from-hos null)
-            (partial-from-hos null))
-        (let-values ([(opt-ps lifted-ps partial-ps hos ho-ctc)
-                      (let loop ([ps ps]
-                                 [next-ps null]
-                                 [lifted-ps null]
-                                 [partial-ps null]
-                                 [hos null]
-                                 [ho-ctc #f])
-                        (cond
-                          [(null? ps) (values next-ps lifted-ps partial-ps (reverse hos) ho-ctc)]
-                          [else
-                           (let-values ([(next lifted partial flat? _)
-                                         (opt/i pos neg (car ps))])
-                             (if flat?
-                                 (loop (cdr ps)
-                                       (cons flat? next-ps)
-                                       (append lifted-ps lifted)
-                                       (append partial-ps partial)
-                                       hos
-                                       ho-ctc)
-                                 (if (< (length hos) 1)
-                                     (loop (cdr ps)
-                                           next-ps
-                                           (append lifted-ps lifted)
-                                           (append partial-ps partial)
-                                           (cons (car ps) hos)
-                                           next)
-                                     (loop (cdr ps)
-                                           next-ps
-                                           lifted-ps
-                                           partial-ps
-                                           (cons (car ps) hos)
-                                           ho-ctc))))]))])
-          (with-syntax ((next-ps (with-syntax (((opt-p ...) opt-ps))
-                                   (syntax (or #f opt-p ...)))))
-            (values
-             (cond
-               [(null? hos) (with-syntax ((pos pos))
-                              (syntax
-                               (if next-ps val
-                                   (raise-contract-error val src-info pos orig-str 
-                                                         "none of the branches of the or/c matched"))))]
-               [(= (length hos) 1) (with-syntax ((ho-ctc ho-ctc))
-                                     (syntax
-                                      (if next-ps val ho-ctc)))]
-               [(> (length hos) 1) 
-                (let-values ([(next-hos lifted-hos partial-hos _ __)
-                              ((opter 'unknown) opt/i pos neg (cons #'or/c hos))])
-                  (set! lifted-from-hos lifted-hos)
-                  (set! partial-from-hos partial-hos)
-                  (with-syntax ((next-hos next-hos))
-                    (syntax
-                     (if next-ps val next-hos))))])
-             (append lifted-ps
-                     lifted-from-hos
-                     (list (cons #'contract-name
-                                 #''or/c-placeholder)))
-             (append partial-ps
-                     partial-from-hos)
-             (if (null? hos)
-                 (syntax next-ps)
-                 #f)
-             (make-known #t stx))))))
-    
-    (syntax-case stx (or/c)
-      [(or/c p ...)
-       (opt/or-ctc (syntax->list (syntax (p ...))))])))
diff --git a/collects/mzlib/private/contract.ss b/collects/mzlib/private/contract.ss
index 097744bec9..7c197ec64b 100644
--- a/collects/mzlib/private/contract.ss
+++ b/collects/mzlib/private/contract.ss
@@ -15,6 +15,7 @@ add struct contracts for immutable structs?
            define/contract)
 
   (require-for-syntax mzscheme
+                      "contract-opt-guts.ss"
                       (lib "list.ss")
                       (lib "stx.ss" "syntax")
                       (lib "name.ss" "syntax"))
@@ -24,7 +25,9 @@ add struct contracts for immutable structs?
            (lib "pretty.ss")
            (lib "pconvert.ss")
            "contract-arrow.ss"
-           "contract-guts.ss")
+           "contract-guts.ss"
+           "contract-opt.ss"
+           "contract-opt-guts.ss")
   
   (require "contract-helpers.ss")
   (require-for-syntax (prefix a: "contract-helpers.ss"))
@@ -727,7 +730,10 @@ add struct contracts for immutable structs?
            box-immutable/c box/c
            promise/c
            struct/c
-	   syntax/c)
+	   syntax/c
+           
+           check-between/c
+           check-unary-between/c)
   
   (define-syntax (flat-rec-contract stx)
     (syntax-case stx  ()
@@ -977,6 +983,74 @@ add struct contracts for immutable structs?
                             this-ctcs
                             that-ctcs))))))
      (flat-prop (λ (ctc) (flat-or/c-pred ctc)))))
+    
+  ;;
+  ;; or/c opter
+  ;;
+  (define/opter (or/c opt/i pos neg stx)
+    (define (opt/or-ctc ps)
+      (let ((lift-from-hos null)
+            (partial-from-hos null))
+        (let-values ([(opt-ps lift-ps partial-ps hos ho-ctc)
+                      (let loop ([ps ps]
+                                 [next-ps null]
+                                 [lift-ps null]
+                                 [partial-ps null]
+                                 [hos null]
+                                 [ho-ctc #f])
+                        (cond
+                          [(null? ps) (values next-ps lift-ps partial-ps (reverse hos) ho-ctc)]
+                          [else
+                           (let-values ([(next lift partial flat _)
+                                         (opt/i pos neg (car ps))])
+                             (if flat
+                                 (loop (cdr ps)
+                                       (cons flat next-ps)
+                                       (append lift-ps lift)
+                                       (append partial-ps partial)
+                                       hos
+                                       ho-ctc)
+                                 (if (< (length hos) 1)
+                                     (loop (cdr ps)
+                                           next-ps
+                                           (append lift-ps lift)
+                                           (append partial-ps partial)
+                                           (cons (car ps) hos)
+                                           next)
+                                     (loop (cdr ps)
+                                           next-ps
+                                           lift-ps
+                                           partial-ps
+                                           (cons (car ps) hos)
+                                           ho-ctc))))]))])
+          (with-syntax ((next-ps (with-syntax (((opt-p ...) opt-ps))
+                                   (syntax (or #f opt-p ...)))))
+            (values
+             (cond
+               [(null? hos) (with-syntax ((pos pos))
+                              (syntax
+                               (if next-ps val
+                                   (raise-contract-error val src-info pos orig-str 
+                                                         "none of the branches of the or/c matched"))))]
+               [(= (length hos) 1) (with-syntax ((ho-ctc ho-ctc))
+                                     (syntax
+                                      (if next-ps val ho-ctc)))]
+               [(> (length hos) 1) 
+                (let-values ([(next-hos lift-hos partial-hos _ __)
+                              ((opter 'unknown) opt/i pos neg (cons #'or/c hos))])
+                  (set! lift-from-hos lift-hos)
+                  (set! partial-from-hos partial-hos)
+                  (with-syntax ((next-hos next-hos))
+                    (syntax
+                     (if next-ps val next-hos))))])
+             (append lift-ps lift-from-hos)
+             (append partial-ps partial-from-hos)
+             (if (null? hos) (syntax next-ps) #f)
+             #f)))))
+    
+    (syntax-case stx (or/c)
+      [(or/c p ...)
+       (opt/or-ctc (syntax->list (syntax (p ...))))]))
   
   (define false/c
     (flat-named-contract
@@ -1079,24 +1153,83 @@ add struct contracts for immutable structs?
                     (λ (x) 
                       (and (number? x)
                            (<= n x m))))))))
-  (define (=/c x) 
+  
+  (define (check-unary-between/c sym x)
     (unless (number? x)
-      (error '=/c "expected a number, got ~e" x))
+      (error sym "expected a number, got ~e" x)))
+  (define (=/c x) 
+    (check-unary-between/c '=/c x)
     (make-between/c x x))
   (define (<=/c x) 
-    (unless (number? x)
-      (error '<=/c "expected a number, got ~e" x))
+    (check-unary-between/c '<=/c x)
     (make-between/c -inf.0 x))
   (define (>=/c x)
-    (unless (number? x)
-      (error '>=/c "expected a number, got ~e" x))
+    (check-unary-between/c '>=/c x)
     (make-between/c x +inf.0))
-  (define (between/c x y)
+  (define (check-between/c x y)
     (unless (number? x)
       (error 'between/c "expected a number as first argument, got ~e, other arg ~e" x y))
     (unless (number? y)
-      (error 'between/c "expected a number as second argument, got ~e, other arg ~e" y x))
+      (error 'between/c "expected a number as second argument, got ~e, other arg ~e" y x)))
+  (define (between/c x y)
+    (check-between/c x y)
     (make-between/c x y))
+  
+  ;;
+  ;; between/c opter helper
+  ;;
+  (define-for-syntax (opt/between-ctc pos stx low high op checker)
+    (let* ((lift-vars (generate-temporaries (syntax (low high error-check))))
+           (lift-low (car lift-vars))
+           (lift-high (cadr lift-vars)))
+      (with-syntax ((pos pos)
+                    (op op)
+                    (n lift-low)
+                    (m lift-high))
+        (values
+         (syntax (if (and (number? val) (op n val m)) val
+                     (raise-contract-error
+                      val
+                      src-info
+                      pos
+                      orig-str
+                      "expected <~a>, given: ~e"
+                      ((name-get ctc) ctc)
+                      val)))
+         (interleave-lifts
+          lift-vars
+          (list low
+                high
+                (cond
+                  [(eq? checker 'between/c) #'(check-between/c n m)]
+                  [(eq? checker '>/c #'(check-unary-between/c '>/c n))]
+                  [(eq? checker '>=/c #'(check-unary-between/c '>=/c n))]
+                  [(eq? checker '</c #'(check-unary-between/c '</c m))]
+                  [(eq? checker '<=/c #'(check-unary-between/c '<=/c m))])))
+         null
+         (syntax (and (number? val) (op n val m)))
+         #f))))
+  
+  ;;
+  ;; between/c and friends' opters
+  ;;
+  ;; note that the checkers are used by both optimized and normal contracts.
+  ;;
+  (define/opter (between/c opt/i pos neg stx)
+    (syntax-case stx (between/c)
+      [(between/c low high) (opt/between-ctc pos stx #'low #'high #'<= 'between/c)]))
+  (define/opter (>/c opt/i pos neg stx)
+    (syntax-case stx (>/c)
+      [(>/c low) (opt/between-ctc #'low #'+inf.0 #'< '>/c)]))
+  (define/opter (>=/c opt/i pos neg stx)
+    (syntax-case stx (>=/c)
+      [(>=/c low) (opt/between-ctc #'low #'+inf.0 #'<= '>=/c)]))
+  (define/opter (</c opt/i pos neg stx)
+    (syntax-case stx (</c)
+      [(</c high) (opt/between-ctc #'-inf.0 #'high #'< '</c)]))
+  (define/opter (<=/c opt/i pos neg stx)
+    (syntax-case stx (<=/c)
+      [(<=/c high) (opt/between-ctc #'-inf.0 #'high #'<= '<=/c)]))
 
   (define (</c x)
     (flat-named-contract
@@ -1267,6 +1400,64 @@ add struct contracts for immutable structs?
             (test-proc/flat-contract hdp (car x))
             (test-proc/flat-contract tlp (cdr x))))))
   
+  ;;
+  ;; cons/c opter
+  ;;
+  (define/opter (cons/c opt/i pos neg stx)
+    (define (opt/cons-ctc hdp tlp)
+      (let-values ([(next-hdp lifts-hdp partials-hdp flat-hdp unknown-hdp)
+                    (opt/i pos neg hdp)]
+                   [(next-tlp lifts-tlp partials-tlp flat-tlp unknown-tlp)
+                    (opt/i pos neg tlp)]
+                   [(error-check) (car (generate-temporaries (syntax (error-check))))])
+        (with-syntax ((next (with-syntax ((flat-hdp flat-hdp)
+                                          (flat-tlp flat-tlp))
+                              (syntax
+                               (and (pair? val)
+                                    (let ((val (car val))) flat-hdp)
+                                    (let ((val (cdr val))) flat-tlp))))))
+          (values
+           (with-syntax ((pos pos))
+             (syntax (if next
+                         val
+                         (raise-contract-error
+                          val
+                          src-info
+                          pos
+                          orig-str
+                          "expected <~a>, given: ~e"
+                          ((name-get ctc) ctc)
+                          val))))
+           (append
+            lifts-hdp lifts-tlp
+            (list (cons error-check
+                        (with-syntax ((hdp hdp)
+                                      (tlp tlp)
+                                      (check (with-syntax ((flat-hdp
+                                                            (cond
+                                                              [unknown-hdp
+                                                               (with-syntax ((ctc unknown-hdp))
+                                                                 (syntax (flat-contract/predicate? ctc)))]
+                                                              [else (if flat-hdp #'#t #'#f)]))
+                                                           (flat-tlp
+                                                            (cond
+                                                              [unknown-tlp
+                                                               (with-syntax ((ctc unknown-tlp))
+                                                                 (syntax (flat-contract/predicate? ctc)))]
+                                                              [else (if flat-tlp #'#t #'#f)])))
+                                               (syntax (and flat-hdp flat-tlp)))))
+                          (syntax
+                           (unless check
+                             (error 'cons/c "expected two flat contracts or procedures of arity 1, got: ~e and ~e"
+                                    hdp tlp)))))))
+           (append partials-hdp partials-tlp)
+           (syntax (if next #t #f))
+           #f))))
+    
+    (syntax-case stx (cons/c)
+      [(cons/c hdp tlp)
+       (opt/cons-ctc #'hdp #'tlp)]))
+  
   (define-syntax (*-immutable/c stx)
     (syntax-case stx ()
       [(_ predicate? constructor (arb? selectors ...) type-name name)
@@ -1344,6 +1535,45 @@ add struct contracts for immutable structs?
                                             (λ (n v) (= n (vector-length v)))
                                             immutable-vector
                                             vector-immutable/c))
+  
+  ;;
+  ;; cons-immutable/c opter
+  ;;
+  (define/opter (cons-immutable/c opt/i pos neg stx)
+    (define (opt/cons-immutable-ctc hdp tlp)
+      (let-values ([(next-hdp lifts-hdp partials-hdp flat-hdp unknown-hdp)
+                    (opt/i pos neg hdp)]
+                   [(next-tlp lifts-tlp partials-tlp flat-tlp unknown-tlp)
+                    (opt/i pos neg tlp)])
+        (with-syntax ((check (syntax (and (immutable? val) (pair? val)))))
+          (values
+           (with-syntax ((pos pos)
+                         (next-hdp next-hdp)
+                         (next-tlp next-tlp))
+             (syntax (if check
+                         (cons-immutable (let ((val (car val))) next-hdp)
+                                         (let ((val (cdr val))) next-tlp))
+                         (raise-contract-error
+                          val
+                          src-info
+                          pos
+                          orig-str
+                          "expected <~a>, given: ~e"
+                          ((name-get ctc) ctc)
+                          val))))        
+           (append lifts-hdp lifts-tlp) 
+           (append partials-hdp partials-tlp)
+           (if (and flat-hdp flat-tlp)
+               (with-syntax ((flat-hdp flat-hdp)
+                             (flat-tlp flat-tlp))
+                 (syntax (if (and check
+                                  (let ((val (car val))) flat-hdp)
+                                  (let ((val (cdr val))) flat-tlp)) #t #f)))
+               #f)
+           #f))))
+    
+    (syntax-case stx (cons-immutable/c)
+      [(cons-immutable/c hdp tlp) (opt/cons-immutable-ctc #'hdp #'tlp)]))
        
   (define (list/c . args)
     (unless (andmap flat-contract/predicate? args)
diff --git a/collects/tests/mzscheme/contract-opt-tests.ss b/collects/tests/mzscheme/contract-opt-tests.ss
index b2e34ed559..947ade0287 100644
--- a/collects/tests/mzscheme/contract-opt-tests.ss
+++ b/collects/tests/mzscheme/contract-opt-tests.ss
@@ -1,7 +1,5 @@
 (module contract-opt-tests mzscheme
-  (require (lib "private/contract-opt.scm")
-           (lib "private/contract-opters.scm")
-           (lib "contract.ss")
+  (require (lib "contract.ss")
            (planet "test.ss" ("schematics" "schemeunit.plt" 2 1)))
     
   (define (exn:fail:contract-violation? exn)
@@ -141,9 +139,15 @@
      
      (test-exn
       "between/c 2"
-      (match-msg "expected two numbers")
+      (match-msg "expected a number as first")
       (λ ()
         (contract (opt/c (between/c 'x 'b)) 1 'pos 'neg)))
+     
+     (test-exn
+      "between/c 3"
+      (match-msg "expected a number as second")
+      (λ ()
+        (contract (opt/c (between/c 1 'b)) 1 'pos 'neg)))
       
      ))