diff --git a/collects/mzlib/contract.ss b/collects/mzlib/contract.ss
index d43e465..1fe5599 100644
--- a/collects/mzlib/contract.ss
+++ b/collects/mzlib/contract.ss
@@ -1,10 +1,79 @@
 #lang scheme/base
-(require scheme/contract)
-(provide (all-from-out scheme/contract))
 
-;; provide contracts for objects
-(require scheme/private/contract-object)
-(provide (all-from-out scheme/private/contract-object))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  provide arrow contracts from our local copy
+;;
+
+(require "private/contract-arrow.ss")
+(provide (all-from-out "private/contract-arrow.ss"))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  provide contracts for objects
+;;
+(require "private/contract-object.ss")
+(provide (all-from-out "private/contract-object.ss"))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; provide everything from the scheme/ implementation
+;; except the arrow contracts
+;;
+
+(require scheme/private/contract
+         scheme/private/contract-guts
+         scheme/private/contract-ds
+         scheme/private/contract-opt-guts
+         scheme/private/contract-opt
+         scheme/private/contract-basic-opters)
+
+(provide 
+ opt/c define-opt/c ;(all-from "private/contract-opt.ss")
+ (except-out (all-from-out scheme/private/contract-ds)
+             lazy-depth-to-look)
  
+ (except-out (all-from-out scheme/private/contract)
+             check-between/c
+             check-unary-between/c))
 
+;; from contract-guts.ss
 
+(provide any
+         and/c
+         any/c
+         none/c
+         make-none/c 
+         
+         guilty-party
+         contract-violation->string
+         
+         contract?
+         contract-name
+         contract-proc
+         
+         flat-contract?
+         flat-contract
+         flat-contract-predicate
+         flat-named-contract
+         
+         contract-first-order-passes?
+         
+         ;; below need docs
+         
+         make-proj-contract
+         
+         contract-stronger?
+         
+         coerce-contract 
+         flat-contract/predicate?
+         
+         build-compound-type-name
+         raise-contract-error
+         
+         proj-prop proj-pred? proj-get
+         name-prop name-pred? name-get
+         stronger-prop stronger-pred? stronger-get
+         flat-prop flat-pred? flat-get
+         first-order-prop first-order-get)
diff --git a/collects/mzlib/private/contract-arrow.ss b/collects/mzlib/private/contract-arrow.ss
new file mode 100644
index 0000000..ee60620
--- /dev/null
+++ b/collects/mzlib/private/contract-arrow.ss
@@ -0,0 +1,535 @@
+#lang scheme/base
+
+(require scheme/private/contract-guts
+         scheme/private/contract-arr-checks
+         scheme/private/contract-opt)
+(require (for-syntax scheme/base)
+         (for-syntax scheme/private/contract-opt-guts)
+         (for-syntax scheme/private/contract-helpers)
+         (for-syntax scheme/private/contract-arr-obj-helpers)
+         (for-syntax syntax/stx)
+         (for-syntax syntax/name))
+
+(provide ->
+         ->d
+         ->*
+         ->d*
+         ->r
+         ->pp
+         ->pp-rest
+         case->
+         opt->
+         opt->*
+         unconstrained-domain->)
+
+(define-syntax (unconstrained-domain-> stx)
+  (syntax-case stx ()
+    [(_ rngs ...)
+     (with-syntax ([(rngs-x ...) (generate-temporaries #'(rngs ...))]
+                   [(proj-x ...) (generate-temporaries #'(rngs ...))]
+                   [(p-app-x ...) (generate-temporaries #'(rngs ...))]
+                   [(res-x ...) (generate-temporaries #'(rngs ...))])
+       #'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...)
+           (let ([proj-x ((proj-get rngs-x) rngs-x)] ...)
+             (make-proj-contract
+              (build-compound-type-name 'unconstrained-domain-> ((name-get rngs-x) rngs-x) ...)
+              (λ (pos-blame neg-blame src-info orig-str)
+                (let ([p-app-x (proj-x pos-blame neg-blame src-info orig-str)] ...)
+                  (λ (val)
+                    (if (procedure? val)
+                        (λ args
+                          (let-values ([(res-x ...) (apply val args)])
+                            (values (p-app-x res-x) ...)))
+                        (raise-contract-error val
+                                              src-info
+                                              pos-blame
+                                              orig-str
+                                              "expected a procedure")))))
+              procedure?))))]))
+
+(define (build--> name doms doms-rest rngs kwds quoted-kwds rng-any? func)
+  (let ([doms/c (map (λ (dom) (coerce-contract name dom)) doms)]
+        [rngs/c (map (λ (rng) (coerce-contract name rng)) rngs)]
+        [kwds/c (map (λ (kwd) (coerce-contract name kwd)) kwds)]
+        [doms-rest/c (and doms-rest (coerce-contract name doms-rest))])
+    (make--> rng-any? doms/c doms-rest/c rngs/c kwds/c quoted-kwds func)))
+;; rng-any? : boolean
+;; doms : (listof contract)
+;; dom-rest : (or/c false/c contract)
+;; rngs : (listof contract) -- may be ignored by the wrapper function in the case of any
+;; kwds : (listof contract)
+;; quoted-keywords : (listof keyword) -- must be sorted by keyword<
+;; func : the wrapper function maker. It accepts a procedure for
+;;        checking the first-order properties and the contracts
+;;        and it produces a wrapper-making function.
+(define-struct/prop -> (rng-any? doms dom-rest rngs kwds quoted-kwds func)
+  ((proj-prop (λ (ctc) 
+                (let* ([doms/c (map (λ (x) ((proj-get x) x)) 
+                                    (if (->-dom-rest ctc)
+                                        (append (->-doms ctc) (list (->-dom-rest ctc)))
+                                        (->-doms ctc)))]
+                       [rngs/c (map (λ (x) ((proj-get x) x)) (->-rngs ctc))]
+                       [kwds/c (map (λ (x) ((proj-get x) x)) (->-kwds ctc))]
+                       [mandatory-keywords (->-quoted-kwds ctc)]
+                       [func (->-func ctc)]
+                       [dom-length (length (->-doms ctc))]
+                       [has-rest? (and (->-dom-rest ctc) #t)])
+                  (lambda (pos-blame neg-blame src-info orig-str)
+                    (let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str))
+                                             doms/c)]
+                          [partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str))
+                                               rngs/c)]
+                          [partial-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str))
+                                             kwds/c)])
+                      (apply func
+                             (λ (val)
+                               (if has-rest?
+                                   (check-procedure/more val dom-length '() mandatory-keywords src-info pos-blame orig-str)
+                                   (check-procedure val dom-length 0 '() mandatory-keywords src-info pos-blame orig-str)))
+                             (append partial-doms partial-ranges partial-kwds)))))))
+   (name-prop (λ (ctc) (single-arrow-name-maker 
+                        (->-doms ctc)
+                        (->-dom-rest ctc)
+                        (->-kwds ctc)
+                        (->-quoted-kwds ctc)
+                        (->-rng-any? ctc)
+                        (->-rngs ctc))))
+   (first-order-prop
+    (λ (ctc)
+      (let ([l (length (->-doms ctc))])
+        (if (->-dom-rest ctc)
+            (λ (x)
+              (and (procedure? x) 
+                   (procedure-accepts-and-more? x l)))
+            (λ (x)
+              (and (procedure? x) 
+                   (procedure-arity-includes? x l)
+                   (no-mandatory-keywords? x)))))))
+   (stronger-prop
+    (λ (this that)
+      (and (->? that)
+           (= (length (->-doms that))
+              (length (->-doms this)))
+           (andmap contract-stronger?
+                   (->-doms that)
+                   (->-doms this))
+           (= (length (->-rngs that))
+              (length (->-rngs this)))
+           (andmap contract-stronger?
+                   (->-rngs this) 
+                   (->-rngs that)))))))
+
+(define (single-arrow-name-maker doms/c doms-rest kwds/c kwds rng-any? rngs)
+  (cond
+    [doms-rest
+     (build-compound-type-name 
+      '->*
+      (apply build-compound-type-name (append doms/c (apply append (map list kwds kwds/c))))
+      doms-rest
+      (cond
+        [rng-any? 'any]
+        [else (apply build-compound-type-name rngs)]))]
+    [else
+     (let ([rng-name
+            (cond
+              [rng-any? 'any]
+              [(null? rngs) '(values)]
+              [(null? (cdr rngs)) (car rngs)]
+              [else (apply build-compound-type-name 'values rngs)])])
+       (apply build-compound-type-name 
+              '->
+              (append doms/c
+                      (apply append (map list kwds kwds/c))
+                      (list rng-name))))]))
+
+(define-for-syntax (sort-keywords stx kwd/ctc-pairs)
+  (define (insert x lst)
+    (cond
+      [(null? lst) (list x)]
+      [else
+       (let ([fst-kwd (syntax-e (car (car lst)))])
+         (printf "comparing ~s to ~s\n" (car x) fst-kwd)
+         (cond
+           [(equal? (syntax-e (car x)) fst-kwd)
+            (raise-syntax-error #f 
+                                "duplicate keyword"
+                                stx
+                                (car x))]
+           [(keyword<? (syntax-e (car x)) fst-kwd)
+            (cons x lst)]
+           [else (cons (car lst) (insert x (cdr lst)))]))]))
+  
+  (let loop ([pairs (map syntax->list kwd/ctc-pairs)])
+    (cond
+      [(null? pairs) null]
+      [else (insert (car pairs) (loop (cdr pairs)))])))
+
+(define-for-syntax (split-doms stx name raw-doms)
+  (let loop ([raw-doms raw-doms]
+             [doms '()]
+             [kwd-doms '()])
+    (syntax-case raw-doms ()
+      [() (list (reverse doms)
+                (sort-keywords stx kwd-doms))]
+      [(kwd arg . rest)
+       (and (keyword? (syntax-e #'kwd))
+            (not (keyword? (syntax-e #'arg))))
+       (loop #'rest
+             doms
+             (cons #'(kwd arg) kwd-doms))]
+      [(kwd arg . rest)
+       (and (keyword? (syntax-e #'kwd))
+            (keyword? (syntax-e #'arg)))
+       (raise-syntax-error name
+                           "expected a keyword followed by a contract"
+                           stx
+                           #'kwd)]
+      [(kwd)
+       (keyword? (syntax-e #'kwd))
+       (raise-syntax-error name
+                           "expected a keyword to be followed by a contract"
+                           stx
+                           #'kwd)]
+      [(x . rest)
+       (loop #'rest (cons #'x doms) kwd-doms)])))
+
+(define-for-syntax (->-helper stx)
+  (syntax-case stx ()
+    [(-> raw-doms ... last-one)
+     (with-syntax ([((doms ...) ((dom-kwd dom-kwd-ctc) ...)) (split-doms stx '-> #'(raw-doms ...))])
+       (with-syntax ([(dom-kwd-arg ...) (generate-temporaries (syntax (dom-kwd ...)))]
+                     [(dom-kwd-ctc-id ...) (generate-temporaries (syntax (dom-kwd ...)))])
+         (with-syntax ([(keyword-call/ctc ...) (apply append (map syntax->list (syntax->list #'((dom-kwd (dom-kwd-ctc-id dom-kwd-arg)) ...))))]
+                       [(keyword-formal-parameters ...) (apply append (map syntax->list (syntax->list #'((dom-kwd dom-kwd-arg) ...))))]
+                       [(args ...) (generate-temporaries (syntax (doms ...)))]
+                       [(dom-ctc ...) (generate-temporaries (syntax (doms ...)))])
+           (syntax-case* #'last-one (-> any values) module-or-top-identifier=?
+             [any
+              (with-syntax ([(ignored) (generate-temporaries (syntax (rng)))])
+                (values (syntax (dom-ctc ...))
+                        (syntax (ignored))
+                        (syntax (dom-kwd-ctc-id ...))
+                        (syntax (doms ...))
+                        (syntax (any/c))
+                        (syntax (dom-kwd-ctc ...))
+                        (syntax (dom-kwd ...))
+                        (syntax ((args ... keyword-formal-parameters ...) (val (dom-ctc args) ... keyword-call/ctc ...)))
+                        #t))]
+             [(values rngs ...)
+              (with-syntax ([(rng-x ...) (generate-temporaries (syntax (rngs ...)))]
+                            [(rng-ctc ...) (generate-temporaries (syntax (rngs ...)))])
+                (values (syntax (dom-ctc ...))
+                        (syntax (rng-ctc ...))
+                        (syntax (dom-kwd-ctc-id ...))
+                        (syntax (doms ...))
+                        (syntax (rngs ...))
+                        (syntax (dom-kwd-ctc ...))
+                        (syntax (dom-kwd ...))
+                        (syntax ((args ... keyword-formal-parameters ...) 
+                                 (let-values ([(rng-x ...) (val (dom-ctc args) ... keyword-call/ctc ...)])
+                                   (values (rng-ctc rng-x) ...))))
+                        #f))]
+             [rng
+              (with-syntax ([(rng-ctc) (generate-temporaries (syntax (rng)))])
+                (values (syntax (dom-ctc ...))
+                        (syntax (rng-ctc))
+                        (syntax (dom-kwd-ctc-id ...))
+                        (syntax (doms ...))
+                        (syntax (rng))
+                        (syntax (dom-kwd-ctc ...))
+                        (syntax (dom-kwd ...))
+                        (syntax ((args ... keyword-formal-parameters ...) (rng-ctc (val (dom-ctc args) ... keyword-call/ctc ...))))
+                        #f))]))))]))
+
+;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names])
+(define-for-syntax (->/proc/main stx)
+  (let-values ([(dom-names rng-names kwd-names dom-ctcs rng-ctcs kwd-ctcs kwds inner-args/body use-any?) (->-helper stx)])
+    (with-syntax ([(args body) inner-args/body])
+      (with-syntax ([(dom-names ...) dom-names]
+                    [(rng-names ...) rng-names]
+                    [(kwd-names ...) kwd-names]
+                    [(dom-ctcs ...) dom-ctcs]
+                    [(rng-ctcs ...) rng-ctcs]
+                    [(kwd-ctcs ...) kwd-ctcs]
+                    [(kwds ...) kwds]
+                    [inner-lambda 
+                     (add-name-prop
+                      (syntax-local-infer-name stx)
+                      (syntax (lambda args body)))]
+                    [use-any? use-any?])
+        (with-syntax ([outer-lambda
+                       (syntax
+                        (lambda (chk dom-names ... rng-names ... kwd-names ...)
+                          (lambda (val)
+                            (chk val)
+                            inner-lambda)))])
+          (values
+           (syntax (build--> '->
+                             (list dom-ctcs ...)
+                             #f
+                             (list rng-ctcs ...)
+                             (list kwd-ctcs ...)
+                             '(kwds ...)
+                             use-any?
+                             outer-lambda))
+           inner-args/body
+           (syntax (dom-names ... rng-names ...))))))))
+  
+(define-syntax (-> stx) 
+  (let-values ([(stx _1 _2) (->/proc/main stx)])
+    stx))
+
+;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names])
+(define-for-syntax (->*/proc/main stx)
+  (syntax-case* stx (->* any) module-or-top-identifier=?
+    [(->* (doms ...) any)
+     (->/proc/main (syntax (-> doms ... any)))]
+    [(->* (doms ...) (rngs ...))
+     (->/proc/main (syntax (-> doms ... (values rngs ...))))]
+    [(->* (raw-doms ...) rst rng)
+     (with-syntax ([((doms ...) ((dom-kwd dom-kwd-ctc) ...)) (split-doms stx '-> #'(raw-doms ...))])
+       (with-syntax ([(dom-kwd-arg ...) (generate-temporaries (syntax (dom-kwd ...)))]
+                     [(dom-kwd-ctc-id ...) (generate-temporaries (syntax (dom-kwd ...)))])
+         (with-syntax ([(keyword-formal-parameters ...) (apply append (map syntax->list (syntax->list #'((dom-kwd dom-kwd-arg) ...))))]
+                       [(args ...) (generate-temporaries (syntax (doms ...)))]
+                       [(dom-ctc ...) (generate-temporaries (syntax (doms ...)))])
+           (with-syntax ([(dom-x ...) (generate-temporaries (syntax (doms ...)))]
+                         [(args ...) (generate-temporaries (syntax (doms ...)))]
+                         [(rst-x) (generate-temporaries (syntax (rst)))]
+                         [(rest-arg) (generate-temporaries (syntax (rst)))])
+             (syntax-case #'rng (any)
+               [(rngs ...)
+                (with-syntax ([(rng-x ...) (generate-temporaries (syntax (rngs ...)))]
+                              [(rng-args ...) (generate-temporaries (syntax (rngs ...)))])
+                  
+                  (let ([inner-args/body 
+                         #`((args ... keyword-formal-parameters ... . rest-arg)
+                            (let-values ([(rng-args ...)
+                                          #,(if (null? (syntax-e #'(dom-kwd ...)))
+                                                #'(apply val (dom-x args) ... (rst-x rest-arg))
+                                                #'(keyword-apply val 
+                                                                 '(dom-kwd ...)
+                                                                 (list (dom-kwd-ctc-id dom-kwd-arg) ...) 
+                                                                 (dom-x args) ...
+                                                                 (rst-x rest-arg)))])
+                              (values (rng-x rng-args) ...)))])
+                    (with-syntax ([inner-lambda (with-syntax ([(args body) inner-args/body])
+                                                  (add-name-prop
+                                                   (syntax-local-infer-name stx)
+                                                   (syntax (lambda args body))))])
+                      (with-syntax ([outer-lambda 
+                                     (syntax
+                                      (lambda (chk dom-x ... rst-x rng-x ... dom-kwd-ctc-id ...)
+                                        (lambda (val)
+                                          (chk val)
+                                          inner-lambda)))])
+                        (values (syntax (build--> '->*
+                                                  (list doms ...)
+                                                  rst
+                                                  (list rngs ...)
+                                                  (list dom-kwd-ctc ...)
+                                                  '(dom-kwd ...)
+                                                  #f 
+                                                  outer-lambda))
+                                inner-args/body
+                                (syntax (dom-x ... rst-x rng-x ...)))))))]
+               [any
+                (let ([inner-args/body 
+                       #`((args ... keyword-formal-parameters ... . rest-arg)
+                          #,(if (null? (syntax-e #'(dom-kwd ...)))
+                                #'(apply val (dom-x args) ... (rst-x rest-arg))
+                                #'(keyword-apply val
+                                                 '(dom-kwd ...) 
+                                                 (list (dom-kwd-ctc-id dom-kwd-arg) ...)
+                                                 (dom-x args) ...
+                                                 (rst-x rest-arg))))])
+                  (with-syntax ([inner-lambda (with-syntax ([(args body) inner-args/body])
+                                                (add-name-prop
+                                                 (syntax-local-infer-name stx)
+                                                 (syntax (lambda args body))))])
+                    (with-syntax ([outer-lambda 
+                                   (syntax
+                                    (lambda (chk dom-x ... rst-x ignored dom-kwd-ctc-id ...)
+                                      (lambda (val)
+                                        (chk val)
+                                        inner-lambda)))])
+                      (values (syntax (build--> '->*
+                                                (list doms ...)
+                                                rst
+                                                (list any/c)
+                                                (list dom-kwd-ctc ...)
+                                                '(dom-kwd ...)
+                                                #t
+                                                outer-lambda))
+                              inner-args/body
+                              (syntax (dom-x ... rst-x))))))])))))]))
+
+(define-syntax (->* stx) 
+  (let-values ([(stx _1 _2) (->*/proc/main stx)])
+    stx))
+
+(define-for-syntax (select/h stx err-name ctxt-stx)
+  (syntax-case stx (-> ->* ->d ->d* ->r ->pp ->pp-rest)
+    [(-> . args) ->/h]
+    [(->* . args) ->*/h]
+    [(->d . args) ->d/h]
+    [(->d* . args) ->d*/h]
+    [(->r . args) ->r/h]
+    [(->pp . args) ->pp/h]
+    [(->pp-rest . args) ->pp-rest/h]
+    [(xxx . args) (raise-syntax-error err-name "unknown arrow constructor" ctxt-stx (syntax xxx))]
+    [_ (raise-syntax-error err-name "malformed arrow clause" ctxt-stx stx)]))
+
+(define-syntax (->d stx) (make-/proc #f ->d/h stx))
+(define-syntax (->d* stx) (make-/proc #f ->d*/h stx))
+(define-syntax (->r stx) (make-/proc #f ->r/h stx))
+(define-syntax (->pp stx) (make-/proc #f ->pp/h stx))
+(define-syntax (->pp-rest stx) (make-/proc #f ->pp-rest/h stx))
+(define-syntax (case-> stx) (make-case->/proc #f stx stx select/h))
+(define-syntax (opt-> stx) (make-opt->/proc #f stx select/h #'case-> #'->))
+(define-syntax (opt->* stx) (make-opt->*/proc #f stx stx select/h #'case-> #'->))
+
+;;
+;; arrow opter
+;;
+(define/opter (-> opt/i opt/info stx)
+  (define (opt/arrow-ctc doms rngs)
+    (let*-values ([(dom-vars rng-vars) (values (generate-temporaries doms)
+                                               (generate-temporaries rngs))]
+                  [(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom)
+                   (let loop ([vars dom-vars]
+                              [doms doms]
+                              [next-doms null]
+                              [lifts-doms null]
+                              [superlifts-doms null]
+                              [partials-doms null]
+                              [stronger-ribs null])
+                     (cond
+                       [(null? doms) (values (reverse next-doms)
+                                             lifts-doms
+                                             superlifts-doms
+                                             partials-doms
+                                             stronger-ribs)]
+                       [else
+                        (let-values ([(next lift superlift partial _ __ this-stronger-ribs)
+                                      (opt/i (opt/info-swap-blame opt/info) (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 superlifts-doms superlift)
+                                (append partials-doms partial)
+                                (append this-stronger-ribs stronger-ribs)))]))]
+                  [(next-rngs lifts-rngs superlifts-rngs partials-rngs stronger-ribs-rng)
+                   (let loop ([vars rng-vars]
+                              [rngs rngs]
+                              [next-rngs null]
+                              [lifts-rngs null]
+                              [superlifts-rngs null]
+                              [partials-rngs null]
+                              [stronger-ribs null])
+                     (cond
+                       [(null? rngs) (values (reverse next-rngs)
+                                             lifts-rngs
+                                             superlifts-rngs
+                                             partials-rngs
+                                             stronger-ribs)]
+                       [else
+                        (let-values ([(next lift superlift partial _ __ this-stronger-ribs)
+                                      (opt/i opt/info (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 superlifts-rngs superlift)
+                                (append partials-rngs partial)
+                                (append this-stronger-ribs stronger-ribs)))]))])
+      (values
+       (with-syntax ((pos (opt/info-pos opt/info))
+                     (src-info (opt/info-src-info opt/info))
+                     (orig-str (opt/info-orig-str opt/info))
+                     ((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 0 '() '() #| keywords |# src-info pos orig-str)
+                   (λ (dom-arg ...)
+                     (let-values ([(rng-arg ...) (val next-dom ...)])
+                       (values next-rng ...))))))
+       (append lifts-doms lifts-rngs)
+       (append superlifts-doms superlifts-rngs)
+       (append partials-doms partials-rngs)
+       #f
+       #f
+       (append stronger-ribs-dom stronger-ribs-rng))))
+  
+  (define (opt/arrow-any-ctc doms)
+    (let*-values ([(dom-vars) (generate-temporaries doms)]
+                  [(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom)
+                   (let loop ([vars dom-vars]
+                              [doms doms]
+                              [next-doms null]
+                              [lifts-doms null]
+                              [superlifts-doms null]
+                              [partials-doms null]
+                              [stronger-ribs null])
+                     (cond
+                       [(null? doms) (values (reverse next-doms)
+                                             lifts-doms
+                                             superlifts-doms
+                                             partials-doms
+                                             stronger-ribs)]
+                       [else
+                        (let-values ([(next lift superlift partial flat _ this-stronger-ribs)
+                                      (opt/i (opt/info-swap-blame opt/info) (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 superlifts-doms superlift)
+                                (append partials-doms partial)
+                                (append this-stronger-ribs stronger-ribs)))]))])
+      (values
+       (with-syntax ((pos (opt/info-pos opt/info))
+                     (src-info (opt/info-src-info opt/info))
+                     (orig-str (opt/info-orig-str opt/info))
+                     ((dom-arg ...) dom-vars)
+                     ((next-dom ...) next-doms)
+                     (dom-len (length dom-vars)))
+         (syntax (begin
+                   (check-procedure val dom-len 0 '() '() #|keywords|# src-info pos orig-str)
+                   (λ (dom-arg ...)
+                     (val next-dom ...)))))
+       lifts-doms
+       superlifts-doms
+       partials-doms
+       #f
+       #f
+       stronger-ribs-dom)))
+  
+  (syntax-case* stx (-> values any) module-or-top-identifier=?
+    [(-> dom ... (values rng ...))
+     (if (ormap (λ (x) (keyword? (syntax-e x))) (syntax->list #'(dom ...)))
+         (opt/unknown opt/i opt/info stx) ;; give up if there is a mandatory keyword 
+         (opt/arrow-ctc (syntax->list (syntax (dom ...)))
+                        (syntax->list (syntax (rng ...)))))]
+    [(-> dom ... any)
+     (if (ormap (λ (x) (keyword? (syntax-e x))) (syntax->list #'(dom ...)))
+         (opt/unknown opt/i opt/info stx) ;; give up if there is a mandatory keyword 
+         (opt/arrow-any-ctc (syntax->list (syntax (dom ...)))))]
+    [(-> dom ... rng)
+     (if (ormap (λ (x) (keyword? (syntax-e x))) (syntax->list #'(dom ...)))
+         (opt/unknown opt/i opt/info stx) ;; give up if there is a mandatory keyword 
+         (opt/arrow-ctc (syntax->list (syntax (dom ...)))
+                        (list #'rng)))]))
diff --git a/collects/mzlib/private/contract-object.ss b/collects/mzlib/private/contract-object.ss
new file mode 100644
index 0000000..15cf8e5
--- /dev/null
+++ b/collects/mzlib/private/contract-object.ss
@@ -0,0 +1,443 @@
+#lang scheme/base
+(require "contract-arrow.ss"
+         scheme/private/contract-guts
+         scheme/private/class-internal
+         scheme/private/contract-arr-checks)
+
+(require (for-syntax scheme/base
+                     scheme/private/contract-helpers
+                     scheme/private/contract-arr-obj-helpers))
+
+(provide mixin-contract
+         make-mixin-contract
+         is-a?/c 
+         subclass?/c 
+         implementation?/c
+         object-contract)
+
+(define-syntax object-contract
+  (let ()
+    (define (obj->/proc stx) (make-/proc #t ->/h stx))
+    (define (obj->*/proc stx) (make-/proc #t ->*/h stx))
+    (define (obj->d/proc stx) (make-/proc #t ->d/h stx))
+    (define (obj->d*/proc stx) (make-/proc #t ->d*/h stx))
+    (define (obj->r/proc stx) (make-/proc #t ->r/h stx))
+    (define (obj->pp/proc stx) (make-/proc #t ->pp/h stx))
+    (define (obj->pp-rest/proc stx) (make-/proc #t ->pp-rest/h stx))
+    (define (obj-case->/proc stx) (make-case->/proc #t stx stx select/h))
+    
+    ;; WARNING: select/h is copied from contract-arrow.ss. I'm not sure how
+    ;; I can avoid this duplication -robby
+    (define (select/h stx err-name ctxt-stx)
+      (syntax-case stx (-> ->* ->d ->d* ->r ->pp ->pp-rest)
+        [(-> . args) ->/h]
+        [(->* . args) ->*/h]
+        [(->d . args) ->d/h]
+        [(->d* . args) ->d*/h]
+        [(->r . args) ->r/h]
+        [(->pp . args) ->pp/h]
+        [(->pp-rest . args) ->pp-rest/h]
+        [(xxx . args) (raise-syntax-error err-name "unknown arrow constructor" ctxt-stx (syntax xxx))]
+        [_ (raise-syntax-error err-name "malformed arrow clause" ctxt-stx stx)]))
+    
+    
+    (define (obj-opt->/proc stx) (make-opt->/proc #t stx select/h #'case-> #'->))
+    (define (obj-opt->*/proc stx) (make-opt->*/proc #t stx stx select/h #'case-> #'->))
+    
+    (λ (stx)
+      
+      ;; name : syntax
+      ;; ctc-stx : syntax[evals to a contract]
+      ;; mtd-arg-stx : syntax[list of arg-specs] (ie, for use in a case-lambda)
+      (define-struct mtd (name ctc-stx mtd-arg-stx))
+      
+      ;; name : syntax
+      ;; ctc-stx : syntax[evals to a contract]
+      (define-struct fld (name ctc-stx))
+      
+      ;; expand-field/mtd-spec : stx -> (union mtd fld)
+      (define (expand-field/mtd-spec f/m-stx)
+        (syntax-case f/m-stx (field)
+          [(field field-name ctc)
+           (identifier? (syntax field-name))
+           (make-fld (syntax field-name) (syntax ctc))]
+          [(field field-name ctc)
+           (raise-syntax-error 'object-contract "expected name of field" stx (syntax field-name))]
+          [(mtd-name ctc)
+           (identifier? (syntax mtd-name))
+           (let-values ([(ctc-stx proc-stx) (expand-mtd-contract (syntax ctc))])
+             (make-mtd (syntax mtd-name)
+                       ctc-stx
+                       proc-stx))]
+          [(mtd-name ctc)
+           (raise-syntax-error 'object-contract "expected name of method" stx (syntax mtd-name))]
+          [_ (raise-syntax-error 'object-contract "expected field or method clause" stx f/m-stx)]))
+      
+      ;; expand-mtd-contract : syntax -> (values syntax[expanded ctc] syntax[mtd-arg])
+      (define (expand-mtd-contract mtd-stx)
+        (syntax-case mtd-stx (case-> opt-> opt->*)
+          [(case-> cases ...)
+           (let loop ([cases (syntax->list (syntax (cases ...)))]
+                      [ctc-stxs null]
+                      [args-stxs null])
+             (cond
+               [(null? cases) 
+                (values
+                 (with-syntax ([(x ...) (reverse ctc-stxs)])
+                   (obj-case->/proc (syntax (case-> x ...))))
+                 (with-syntax ([(x ...) (apply append (map syntax->list (reverse args-stxs)))])
+                   (syntax (x ...))))]
+               [else
+                (let-values ([(trans ctc-stx mtd-args) (expand-mtd-arrow (car cases))])
+                  (loop (cdr cases)
+                        (cons ctc-stx ctc-stxs)
+                        (cons mtd-args args-stxs)))]))]
+          [(opt->* (req-contracts ...) (opt-contracts ...) (res-contracts ...))
+           (values
+            (obj-opt->*/proc (syntax (opt->* (any/c req-contracts ...) (opt-contracts ...) (res-contracts ...))))
+            (generate-opt->vars (syntax (req-contracts ...))
+                                (syntax (opt-contracts ...))))]
+          [(opt->* (req-contracts ...) (opt-contracts ...) any)
+           (values
+            (obj-opt->*/proc (syntax (opt->* (any/c req-contracts ...) (opt-contracts ...) any)))
+            (generate-opt->vars (syntax (req-contracts ...))
+                                (syntax (opt-contracts ...))))]
+          [(opt-> (req-contracts ...) (opt-contracts ...) res-contract) 
+           (values
+            (obj-opt->/proc (syntax (opt-> (any/c req-contracts ...) (opt-contracts ...) res-contract)))
+            (generate-opt->vars (syntax (req-contracts ...))
+                                (syntax (opt-contracts ...))))]
+          [else 
+           (let-values ([(x y z) (expand-mtd-arrow mtd-stx)])
+             (values (x y) z))]))
+      
+      ;; generate-opt->vars : syntax[requried contracts] syntax[optional contracts] -> syntax[list of arg specs]
+      (define (generate-opt->vars req-stx opt-stx)
+        (with-syntax ([(req-vars ...) (generate-temporaries req-stx)]
+                      [(ths) (generate-temporaries (syntax (ths)))])
+          (let loop ([opt-vars (generate-temporaries opt-stx)])
+            (cond
+              [(null? opt-vars) (list (syntax (ths req-vars ...)))]
+              [else (with-syntax ([(opt-vars ...) opt-vars]
+                                  [(rests ...) (loop (cdr opt-vars))])
+                      (syntax ((ths req-vars ... opt-vars ...)
+                               rests ...)))]))))
+      
+      ;; expand-mtd-arrow : stx -> (values (syntax[ctc] -> syntax[expanded ctc]) syntax[ctc] syntax[mtd-arg])
+      (define (expand-mtd-arrow mtd-stx)
+        (syntax-case mtd-stx (-> ->* ->d ->d* ->r ->pp ->pp-rest)
+          [(->) (raise-syntax-error 'object-contract "-> must have arguments" stx mtd-stx)]
+          [(-> args ...)
+           ;; this case cheats a little bit --
+           ;; (args ...) contains the right number of arguments
+           ;; to the method because it also contains one arg for the result! urgh.
+           (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (args ...)))])
+             (values obj->/proc
+                     (syntax (-> any/c args ...))
+                     (syntax ((arg-vars ...)))))]
+          [(->* (doms ...) (rngs ...))
+           (with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))]
+                         [(this-var) (generate-temporaries (syntax (this-var)))])
+             (values obj->*/proc
+                     (syntax (->* (any/c doms ...) (rngs ...)))
+                     (syntax ((this-var args-vars ...)))))]
+          [(->* (doms ...) rst (rngs ...))
+           (with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))]
+                         [(rst-var) (generate-temporaries (syntax (rst)))]
+                         [(this-var) (generate-temporaries (syntax (this-var)))])
+             (values obj->*/proc
+                     (syntax (->* (any/c doms ...) rst (rngs ...)))
+                     (syntax ((this-var args-vars ... . rst-var)))))]
+          [(->* x ...)
+           (raise-syntax-error 'object-contract "malformed ->*" stx mtd-stx)]
+          [(->d) (raise-syntax-error 'object-contract "->d must have arguments" stx mtd-stx)]
+          [(->d doms ... rng-proc)
+           (let ([doms-val (syntax->list (syntax (doms ...)))])
+             (values
+              obj->d/proc
+              (with-syntax ([(arg-vars ...) (generate-temporaries doms-val)]
+                            [arity-count (length doms-val)])
+                (syntax 
+                 (->d any/c doms ... 
+                      (let ([f rng-proc])
+                        (check->* f arity-count)
+                        (lambda (_this-var arg-vars ...)
+                          (f arg-vars ...))))))
+              (with-syntax ([(args-vars ...) (generate-temporaries doms-val)])
+                (syntax ((this-var args-vars ...))))))]
+          [(->d* (doms ...) rng-proc)
+           (values
+            obj->d*/proc
+            (let ([doms-val (syntax->list (syntax (doms ...)))])
+              (with-syntax ([(arg-vars ...) (generate-temporaries doms-val)]
+                            [arity-count (length doms-val)])
+                (syntax (->d* (any/c doms ...)
+                              (let ([f rng-proc])
+                                (check->* f arity-count)
+                                (lambda (_this-var arg-vars ...)
+                                  (f arg-vars ...)))))))
+            (with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))]
+                          [(this-var) (generate-temporaries (syntax (this-var)))])
+              (syntax ((this-var args-vars ...)))))]
+          [(->d* (doms ...) rst-ctc rng-proc)
+           (let ([doms-val (syntax->list (syntax (doms ...)))])
+             (values
+              obj->d*/proc
+              (with-syntax ([(arg-vars ...) (generate-temporaries doms-val)]
+                            [(rest-var) (generate-temporaries (syntax (rst-ctc)))]
+                            [arity-count (length doms-val)])
+                (syntax (->d* (any/c doms ...)
+                              rst-ctc
+                              (let ([f rng-proc])
+                                (check->*/more f arity-count)
+                                (lambda (_this-var arg-vars ... . rest-var)
+                                  (apply f arg-vars ... rest-var))))))
+              (with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))]
+                            [(rst-var) (generate-temporaries (syntax (rst-ctc)))]
+                            [(this-var) (generate-temporaries (syntax (this-var)))])
+                (syntax ((this-var args-vars ... . rst-var))))))]
+          [(->d* x ...)
+           (raise-syntax-error 'object-contract "malformed ->d* method contract" stx mtd-stx)]
+          
+          [(->r ([x dom] ...) rng)
+           (andmap identifier? (syntax->list (syntax (x ...))))
+           (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]
+                         [(this-var) (generate-temporaries (syntax (this-var)))]
+                         [this (datum->syntax mtd-stx 'this)])
+             (values
+              obj->r/proc
+              (syntax (->r ([this any/c] [x dom] ...) rng))
+              (syntax ((this-var arg-vars ...)))))]
+          
+          [(->r ([x dom] ...) rest-x rest-dom rng)
+           (andmap identifier? (syntax->list (syntax (x ...))))
+           (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]
+                         [(this-var) (generate-temporaries (syntax (this-var)))]
+                         [this (datum->syntax mtd-stx 'this)])
+             (values
+              obj->r/proc
+              (syntax (->r ([this any/c] [x dom] ...) rest-x rest-dom rng))
+              (syntax ((this-var arg-vars ... . rest-var)))))]
+          
+          [(->r . x)
+           (raise-syntax-error 'object-contract "malformed ->r declaration")]
+          [(->pp ([x dom] ...) . other-stuff)
+           (andmap identifier? (syntax->list (syntax (x ...))))
+           (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]
+                         [(this-var) (generate-temporaries (syntax (this-var)))]
+                         [this (datum->syntax mtd-stx 'this)])
+             (values
+              obj->pp/proc
+              (syntax (->pp ([this any/c] [x dom] ...) . other-stuff))
+              (syntax ((this-var arg-vars ...)))))]
+          [(->pp . x)
+           (raise-syntax-error 'object-contract "malformed ->pp declaration")]
+          [(->pp-rest ([x dom] ...) rest-id . other-stuff)
+           (and (identifier? (syntax id))
+                (andmap identifier? (syntax->list (syntax (x ...)))))
+           (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]
+                         [(this-var) (generate-temporaries (syntax (this-var)))]
+                         [this (datum->syntax mtd-stx 'this)])
+             (values
+              obj->pp-rest/proc
+              (syntax (->pp ([this any/c] [x dom] ...) rest-id . other-stuff))
+              (syntax ((this-var arg-vars ... . rest-id)))))]
+          [(->pp-rest . x)
+           (raise-syntax-error 'object-contract "malformed ->pp-rest declaration")]
+          [else (raise-syntax-error 'object-contract "unknown method contract syntax" stx mtd-stx)]))
+      
+      ;; build-methods-stx : syntax[list of lambda arg specs] -> syntax[method realized as proc]
+      (define (build-methods-stx mtds)
+        
+        (define (last-pair l)
+          (cond
+            [(not (pair? (cdr l))) l]
+            [else (last-pair (cdr l))]))
+        
+        (let loop ([arg-spec-stxss (map mtd-mtd-arg-stx mtds)]
+                   [names (map mtd-name mtds)]
+                   [i 0])
+          (cond
+            [(null? arg-spec-stxss) null]
+            [else (let ([arg-spec-stxs (car arg-spec-stxss)])
+                    (with-syntax ([(cases ...)
+                                   (map (lambda (arg-spec-stx)
+                                          (with-syntax ([i i])
+                                            (syntax-case arg-spec-stx ()
+                                              [(this rest-ids ...)
+                                               (syntax
+                                                ((this rest-ids ...)
+                                                 ((field-ref this i) (wrapper-object-wrapped this) rest-ids ...)))]
+                                              [else
+                                               (let-values ([(this rest-ids last-var)
+                                                             (let ([lst (syntax->improper-list arg-spec-stx)])
+                                                               (values (car lst)
+                                                                       (all-but-last (cdr lst))
+                                                                       (cdr (last-pair lst))))])
+                                                 (with-syntax ([this this]
+                                                               [(rest-ids ...) rest-ids]
+                                                               [last-var last-var])
+                                                   (syntax
+                                                    ((this rest-ids ... . last-var)
+                                                     (apply (field-ref this i)
+                                                            (wrapper-object-wrapped this)
+                                                            rest-ids ...
+                                                            last-var)))))])))
+                                        (syntax->list arg-spec-stxs))]
+                                  [name (string->symbol (format "~a method" (syntax->datum (car names))))])
+                      (with-syntax ([proc (syntax-property (syntax (case-lambda cases ...)) 'method-arity-error #t)])
+                        (cons (syntax (lambda (field-ref) (let ([name proc]) name)))
+                              (loop (cdr arg-spec-stxss)
+                                    (cdr names)
+                                    (+ i 1))))))])))
+      
+      (define (syntax->improper-list stx)
+        (define (se->il se)
+          (cond
+            [(pair? se) (sp->il se)]
+            [else se]))
+        (define (stx->il stx)
+          (se->il (syntax-e stx)))
+        (define (sp->il p)
+          (cond
+            [(null? (cdr p)) p]
+            [(pair? (cdr p)) (cons (car p) (sp->il (cdr p)))]
+            [(syntax? (cdr p)) 
+             (let ([un (syntax-e (cdr p))])
+               (if (pair? un)
+                   (cons (car p) (sp->il un))
+                   p))]))
+        (stx->il stx))
+      
+      (syntax-case stx ()
+        [(_ field/mtd-specs ...)
+         (let* ([mtd/flds (map expand-field/mtd-spec (syntax->list (syntax (field/mtd-specs ...))))]
+                [mtds (filter mtd? mtd/flds)]
+                [flds (filter fld? mtd/flds)])
+           (with-syntax ([(method-ctc-stx ...) (map mtd-ctc-stx mtds)]
+                         [(method-name ...) (map mtd-name mtds)]
+                         [(method-ctc-var ...) (generate-temporaries mtds)]
+                         [(method-var ...) (generate-temporaries mtds)]
+                         [(method/app-var ...) (generate-temporaries mtds)]
+                         [(methods ...) (build-methods-stx mtds)]
+                         
+                         [(field-ctc-stx ...) (map fld-ctc-stx flds)]
+                         [(field-name ...) (map fld-name flds)]
+                         [(field-ctc-var ...) (generate-temporaries flds)]
+                         [(field-var ...) (generate-temporaries flds)]
+                         [(field/app-var ...) (generate-temporaries flds)])
+             (syntax
+              (let ([method-ctc-var method-ctc-stx] 
+                    ...
+                    [field-ctc-var (coerce-contract 'object-contract field-ctc-stx)]
+                    ...)
+                (let ([method-var (contract-proc method-ctc-var)] 
+                      ...
+                      [field-var (contract-proc field-ctc-var)]
+                      ...)
+                  (let ([cls (make-wrapper-class 'wrapper-class 
+                                                 '(method-name ...)
+                                                 (list methods ...)
+                                                 '(field-name ...))])
+                    (make-proj-contract
+                     `(object-contract 
+                       ,(build-compound-type-name 'method-name method-ctc-var) ...
+                       ,(build-compound-type-name 'field 'field-name field-ctc-var) ...)
+                     (lambda (pos-blame neg-blame src-info orig-str)
+                       (let ([method/app-var (method-var pos-blame neg-blame src-info orig-str)] 
+                             ...
+                             [field/app-var (field-var pos-blame neg-blame src-info orig-str)]
+                             ...)
+                         (let ([field-names-list '(field-name ...)])
+                           (lambda (val)
+                             (check-object val src-info pos-blame orig-str)
+                             (let ([val-mtd-names
+                                    (interface->method-names
+                                     (object-interface
+                                      val))])
+                               (void)
+                               (check-method val 'method-name val-mtd-names src-info pos-blame orig-str)
+                               ...)
+                             
+                             (unless (field-bound? field-name val)
+                               (field-error val 'field-name src-info pos-blame orig-str)) ...
+                             
+                             (let ([vtable (extract-vtable val)]
+                                   [method-ht (extract-method-ht val)])
+                               (make-object cls
+                                 val
+                                 (method/app-var (vector-ref vtable (hash-table-get method-ht 'method-name))) ...
+                                 (field/app-var (get-field field-name val)) ...
+                                 ))))))
+                     #f)))))))]))))
+
+
+(define (check-object val src-info blame orig-str)
+  (unless (object? val)
+    (raise-contract-error val
+                          src-info
+                          blame
+                          orig-str
+                          "expected an object, got ~e"
+                          val)))
+
+(define (check-method val method-name val-mtd-names src-info blame orig-str)
+  (unless (memq method-name val-mtd-names)
+    (raise-contract-error val
+                          src-info
+                          blame
+                          orig-str
+                          "expected an object with method ~s"
+                          method-name)))
+
+(define (field-error val field-name src-info blame orig-str)
+  (raise-contract-error val
+                        src-info
+                        blame
+                        orig-str
+                        "expected an object with field ~s"
+                        field-name))
+
+(define (make-mixin-contract . %/<%>s)
+  ((and/c (flat-contract class?)
+          (apply and/c (map sub/impl?/c %/<%>s)))
+   . ->d .
+   subclass?/c))
+
+(define (subclass?/c %)
+  (unless (class? %)
+    (error 'subclass?/c "expected <class>, given: ~e" %))
+  (let ([name (object-name %)])
+    (flat-named-contract
+     `(subclass?/c ,(or name 'unknown%))
+     (lambda (x) (subclass? x %)))))
+
+(define (implementation?/c <%>)
+  (unless (interface? <%>)
+    (error 'implementation?/c "expected <interface>, given: ~e" <%>))
+  (let ([name (object-name <%>)])
+    (flat-named-contract
+     `(implementation?/c ,(or name 'unknown<%>))
+     (lambda (x) (implementation? x <%>)))))
+
+(define (sub/impl?/c %/<%>)
+  (cond
+    [(interface? %/<%>) (implementation?/c %/<%>)]
+    [(class? %/<%>) (subclass?/c %/<%>)]
+    [else (error 'make-mixin-contract "unknown input ~e" %/<%>)]))
+
+(define (is-a?/c <%>)
+  (unless (or (interface? <%>)
+              (class? <%>))
+    (error 'is-a?/c "expected <interface> or <class>, given: ~e" <%>))
+  (let ([name (object-name <%>)])
+    (flat-named-contract
+     (cond
+       [name
+        `(is-a?/c ,name)]
+       [(class? <%>)
+        `(is-a?/c unknown%)]
+       [else `(is-a?/c unknown<%>)])
+     (lambda (x) (is-a? x <%>)))))
+
+(define mixin-contract (class? . ->d . subclass?/c))
diff --git a/collects/scheme/private/contract-arr-checks.ss b/collects/scheme/private/contract-arr-checks.ss
index 1c1a399..f4896a9 100644
--- a/collects/scheme/private/contract-arr-checks.ss
+++ b/collects/scheme/private/contract-arr-checks.ss
@@ -93,10 +93,10 @@
                           orig-str
                           "post-condition expression failure")))
 
-(define (check-procedure val dom-length mandatory-kwds src-info blame orig-str)
+(define (check-procedure val dom-length optionals mandatory-kwds optional-keywords src-info blame orig-str)
   (unless (and (procedure? val)
-               (procedure-arity-includes? val dom-length)
-               (equal? mandatory-kwds (get-mandatory-keywords val)))
+               (procedure-arity-includes?/optionals val dom-length optionals)
+               (keywords-match mandatory-kwds optional-keywords val))
     (raise-contract-error
      val
      src-info
@@ -107,6 +107,19 @@
      (keyword-error-text mandatory-kwds)
      val)))
 
+(define (procedure-arity-includes?/optionals f base optionals)
+  (cond
+    [(zero? optionals) (procedure-arity-includes? f base)]
+    [else (and (procedure-arity-includes? f (+ base optionals))
+               (procedure-arity-includes?/optionals f base (- optionals 1)))]))
+
+(define (keywords-match mandatory-kwds optional-kwds val)
+  (let-values ([(proc-mandatory proc-all) (procedure-keywords val)])
+    (and (equal? proc-mandatory mandatory-kwds)
+         (andmap (λ (kwd) (and (member kwd proc-all)
+                               (not (member kwd proc-mandatory))))
+                 optional-kwds))))
+
 (define (keyword-error-text mandatory-keywords)
   (cond
     [(null? mandatory-keywords) " without any keywords"]
@@ -165,10 +178,10 @@
                           (procedure-arity val)
                           val)))
 
-(define (check-procedure/more val dom-length mandatory-kwds src-info blame orig-str)
+(define (check-procedure/more val dom-length mandatory-kwds optional-kwds src-info blame orig-str)
   (unless (and (procedure? val)
                (procedure-accepts-and-more? val dom-length)
-               (equal? mandatory-kwds (get-mandatory-keywords val)))
+               (keywords-match mandatory-kwds optional-kwds val))
     (raise-contract-error
      val
      src-info
diff --git a/collects/scheme/private/contract-arr-obj-helpers.ss b/collects/scheme/private/contract-arr-obj-helpers.ss
index 4e76478..6ca7373 100644
--- a/collects/scheme/private/contract-arr-obj-helpers.ss
+++ b/collects/scheme/private/contract-arr-obj-helpers.ss
@@ -382,7 +382,7 @@
              (lambda (outer-args)
                (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
                  (syntax
-                  (check-procedure val dom-length '() #|mandatory-keywords|# src-info pos-blame orig-str))))
+                  (check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str))))
              (syntax (check-procedure? dom-length))
              (lambda (outer-args)
                (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
@@ -428,7 +428,7 @@
                (lambda (outer-args)
                  (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
                    (syntax
-                    (check-procedure val dom-length '() #|mandatory-keywords|# src-info pos-blame orig-str))))
+                    (check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str))))
                (syntax (check-procedure? dom-length))
                
                (lambda (outer-args)
@@ -472,7 +472,7 @@
                (lambda (outer-args)
                  (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
                    (syntax
-                    (check-procedure val dom-length '() #|mandatory keywords|# src-info pos-blame orig-str))))
+                    (check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str))))
                (syntax (check-procedure? dom-length))
                (lambda (outer-args)
                  (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
@@ -548,7 +548,7 @@
         (lambda (outer-args)
           (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
             (syntax
-             (check-procedure/more val dom-length '() #|mandatory keywords|# src-info pos-blame orig-str))))
+             (check-procedure/more val dom-length '() '() #|keywords|# src-info pos-blame orig-str))))
         (syntax (check-procedure/more? dom-length))
         (lambda (outer-args)
           (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
@@ -610,7 +610,7 @@
         (lambda (outer-args)
           (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
             (syntax
-             (check-procedure/more val dom-length '() #|mandatory keywords|# src-info pos-blame orig-str))))
+             (check-procedure/more val dom-length '() '() #|keywords|# src-info pos-blame orig-str))))
         (syntax (check-procedure/more? dom-length))
         (lambda (outer-args)
           (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
@@ -663,7 +663,7 @@
         (lambda (outer-args)
           (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
             (syntax
-             (check-procedure val arity '() #|mandatory keywords|# src-info pos-blame orig-str))))
+             (check-procedure val arity 0 '() '() #|keywords|# src-info pos-blame orig-str))))
         
         (syntax (check-procedure? arity))
         
@@ -723,7 +723,7 @@
         (lambda (outer-args)
           (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
             (syntax
-             (check-procedure val dom-length '() #|mandatory keywords|# src-info pos-blame orig-str))))
+             (check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str))))
         (syntax (check-procedure? dom-length))
         
         (lambda (outer-args)
@@ -797,7 +797,7 @@
         (lambda (outer-args)
           (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
             (syntax
-             (check-procedure/more val arity '() #|mandatory keywords|# src-info pos-blame orig-str))))
+             (check-procedure/more val arity '() '() #|keywords|# src-info pos-blame orig-str))))
         (syntax (check-procedure/more? arity))
         
         (lambda (outer-args)
diff --git a/collects/scheme/private/contract-arrow.ss b/collects/scheme/private/contract-arrow.ss
index ff2a1cf..fb60c36 100644
--- a/collects/scheme/private/contract-arrow.ss
+++ b/collects/scheme/private/contract-arrow.ss
@@ -2,16 +2,16 @@
 
 #|
 
-keywords done:
+v4 done:
 
-- added mandatory keywords to ->, ->*
+- added mandatory keywords to ->
+- rewrote ->* using new notation
 
-keywords todo:
+v4 todo:
 
-add mandatory keywords to ->d ->d*
+- rewrite ->d
 
-Add both optional and mandatory keywords to opt-> and friends. 
-(Update opt-> so that it doesn't use case-lambda anymore.)
+- remove opt-> opt->* ->pp ->pp-rest ->r ->d*
 
 - raise-syntax-errors
   . multiple identical keywords syntax error, sort-keywords
@@ -66,88 +66,119 @@ Add both optional and mandatory keywords to opt-> and friends.
                                               "expected a procedure")))))
               procedure?))))]))
 
-(define (build--> name doms doms-rest rngs kwds quoted-kwds rng-any? func)
-  (let ([doms/c (map (λ (dom) (coerce-contract name dom)) doms)]
-        [rngs/c (map (λ (rng) (coerce-contract name rng)) rngs)]
-        [kwds/c (map (λ (kwd) (coerce-contract name kwd)) kwds)]
-        [doms-rest/c (and doms-rest (coerce-contract name doms-rest))])
-    (make--> rng-any? doms/c doms-rest/c rngs/c kwds/c quoted-kwds func)))
-;; rng-any? : boolean
+(define (build--> name
+                  doms/c-or-p optional-doms/c-or-p doms-rest/c-or-p-or-f 
+                  mandatory-kwds/c-or-p mandatory-kwds optional-kwds/c-or-p optional-kwds
+                  rngs/c-or-p
+                  rng-any? func)
+  (let ([cc (λ (c-or-p) (coerce-contract name c-or-p))])
+    (make--> 
+     (map cc doms/c-or-p) (map cc optional-doms/c-or-p) (and doms-rest/c-or-p-or-f (cc doms-rest/c-or-p-or-f))
+     (map cc mandatory-kwds/c-or-p) mandatory-kwds (map cc optional-kwds/c-or-p) optional-kwds
+     (map cc rngs/c-or-p) rng-any?
+     func)))
+
 ;; doms : (listof contract)
+;; optional-doms/c : (listof contract)
 ;; dom-rest : (or/c false/c contract)
+;; mandatory-kwds/c : (listof contract)
+;; mandatory-kwds : (listof keyword) -- must be sorted by keyword<
+;; optional-kwds/c : (listof contract)
+;; optional-kwds : (listof keyword) -- must be sorted by keyword<
 ;; rngs : (listof contract) -- may be ignored by the wrapper function in the case of any
-;; kwds : (listof contract)
-;; quoted-keywords : (listof keyword) -- must be sorted by keyword<
+;; rng-any? : boolean
 ;; func : the wrapper function maker. It accepts a procedure for
 ;;        checking the first-order properties and the contracts
 ;;        and it produces a wrapper-making function.
-(define-struct/prop -> (rng-any? doms dom-rest rngs kwds quoted-kwds func)
+(define-struct/prop -> (doms/c optional-doms/c dom-rest/c mandatory-kwds/c mandatory-kwds optional-kwds/c optional-kwds rngs/c rng-any? func)
   ((proj-prop (λ (ctc) 
-                (let* ([doms/c (map (λ (x) ((proj-get x) x)) 
-                                    (if (->-dom-rest ctc)
-                                        (append (->-doms ctc) (list (->-dom-rest ctc)))
-                                        (->-doms ctc)))]
-                       [rngs/c (map (λ (x) ((proj-get x) x)) (->-rngs ctc))]
-                       [kwds/c (map (λ (x) ((proj-get x) x)) (->-kwds ctc))]
-                       [mandatory-keywords (->-quoted-kwds ctc)]
+                (let* ([doms-proj (map (λ (x) ((proj-get x) x)) 
+                                       (if (->-dom-rest/c ctc)
+                                           (append (->-doms/c ctc) (list (->-dom-rest/c ctc)))
+                                           (->-doms/c ctc)))]
+                       [doms-optional-proj (map (λ (x) ((proj-get x) x)) (->-optional-doms/c ctc))]
+                       [rngs-proj (map (λ (x) ((proj-get x) x)) (->-rngs/c ctc))]
+                       [mandatory-kwds-proj (map (λ (x) ((proj-get x) x)) (->-mandatory-kwds/c ctc))]
+                       [optional-kwds-proj (map (λ (x) ((proj-get x) x)) (->-optional-kwds/c ctc))]
+                       [mandatory-keywords (->-mandatory-kwds ctc)]
+                       [optional-keywords (->-optional-kwds ctc)]
                        [func (->-func ctc)]
-                       [dom-length (length (->-doms ctc))]
-                       [check-proc
-                        (if (->-dom-rest ctc)
-                            check-procedure/more
-                            check-procedure)])
-                  (lambda (pos-blame neg-blame src-info orig-str)
+                       [dom-length (length (->-doms/c ctc))]
+                       [optionals-length (length (->-optional-doms/c ctc))]
+                       [has-rest? (and (->-dom-rest/c ctc) #t)])
+                  (λ (pos-blame neg-blame src-info orig-str)
                     (let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str))
-                                             doms/c)]
+                                             doms-proj)]
+                          [partial-optional-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str))
+                                                      doms-optional-proj)]
                           [partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str))
-                                               rngs/c)]
-                          [partial-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str))
-                                             kwds/c)])
+                                               rngs-proj)]
+                          [partial-mandatory-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str))
+                                                       mandatory-kwds-proj)]
+                          [partial-optional-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str))
+                                                      optional-kwds-proj)])
                       (apply func
-                             (λ (val) (check-proc val dom-length mandatory-keywords src-info pos-blame orig-str))
-                             (append partial-doms partial-ranges partial-kwds)))))))
+                             (λ (val) (if has-rest?
+                                          (check-procedure/more val dom-length mandatory-keywords optional-keywords src-info pos-blame orig-str)
+                                          (check-procedure val dom-length optionals-length mandatory-keywords optional-keywords src-info pos-blame orig-str)))
+                             (append partial-doms partial-optional-doms 
+                                     partial-mandatory-kwds partial-optional-kwds
+                                     partial-ranges)))))))
    (name-prop (λ (ctc) (single-arrow-name-maker 
-                        (->-doms ctc)
-                        (->-dom-rest ctc)
-                        (->-kwds ctc)
-                        (->-quoted-kwds ctc)
+                        (->-doms/c ctc)
+                        (->-optional-doms/c ctc)
+                        (->-dom-rest/c ctc)
+                        (->-mandatory-kwds/c ctc)
+                        (->-mandatory-kwds ctc)
+                        (->-optional-kwds/c ctc)
+                        (->-optional-kwds ctc)
                         (->-rng-any? ctc)
-                        (->-rngs ctc))))
+                        (->-rngs/c ctc))))
    (first-order-prop
     (λ (ctc)
-      (let ([l (length (->-doms ctc))])
-        (if (->-dom-rest ctc)
-            (λ (x)
-              (and (procedure? x) 
-                   (procedure-accepts-and-more? x l)))
-            (λ (x)
-              (and (procedure? x) 
-                   (procedure-arity-includes? x l)
-                   (no-mandatory-keywords? x)))))))
+      (λ (x)
+        (let ([l (length (->-doms/c ctc))])
+          (and (procedure? x) 
+               (if (->-dom-rest/c ctc)
+                   (procedure-accepts-and-more? x l)
+                   (procedure-arity-includes? x l))
+               (let-values ([(x-mandatory-keywords x-all-keywords) (procedure-keywords x)])
+                 (and (equal? x-mandatory-keywords (->-mandatory-kwds ctc))
+                      (andmap (λ (optional-keyword) (member optional-keyword x-all-keywords))
+                              (->-mandatory-kwds ctc))))
+               #t)))))
    (stronger-prop
     (λ (this that)
       (and (->? that)
-           (= (length (->-doms that))
-              (length (->-doms this)))
-           (andmap contract-stronger?
-                   (->-doms that)
-                   (->-doms this))
-           (= (length (->-rngs that))
-              (length (->-rngs this)))
-           (andmap contract-stronger?
-                   (->-rngs this) 
-                   (->-rngs that)))))))
+           (= (length (->-doms/c that)) (length (->-doms/c this)))
+           (andmap contract-stronger? (->-doms/c that) (->-doms/c this))
+           
+           (equal? (->-mandatory-kwds this) (->-mandatory-kwds that))
+           (andmap contract-stronger? (->-mandatory-kwds/c that) (->-mandatory-kwds/c this))
+           
+           (equal? (->-optional-kwds this) (->-optional-kwds that))
+           (andmap contract-stronger? (->-optional-kwds/c that) (->-optional-kwds/c this))
+           
+           (= (length (->-rngs/c that)) (length (->-rngs/c this)))
+           (andmap contract-stronger? (->-rngs/c this) (->-rngs/c that)))))))
 
-(define (single-arrow-name-maker doms/c doms-rest kwds/c kwds rng-any? rngs)
+(define (single-arrow-name-maker doms/c optional-doms/c doms-rest kwds/c kwds optional-kwds/c optional-kwds rng-any? rngs)
   (cond
-    [doms-rest
-     (build-compound-type-name 
-      '->*
-      (apply build-compound-type-name (append doms/c (apply append (map list kwds kwds/c))))
-      doms-rest
-      (cond
-        [rng-any? 'any]
-        [else (apply build-compound-type-name rngs)]))]
+    [(or doms-rest 
+         (not (null? optional-kwds))
+         (not (null? optional-doms/c)))
+     (let ([range
+            (cond
+              [rng-any? 'any]
+              [else (apply build-compound-type-name rngs)])])
+       (apply
+        build-compound-type-name 
+        '->*
+        (apply build-compound-type-name (append doms/c (apply append (map list kwds kwds/c))))
+        (apply build-compound-type-name (append optional-doms/c (apply append (map list optional-kwds optional-kwds/c))))
+        (if doms-rest
+            (list doms-rest range)
+            (list range))))]
     [else
      (let ([rng-name
             (cond
@@ -161,24 +192,26 @@ Add both optional and mandatory keywords to opt-> and friends.
                       (apply append (map list kwds kwds/c))
                       (list rng-name))))]))
 
+;; sort-keywords : syntax (listof syntax[(kwd . whatever)] -> (listof syntax[(kwd . whatever)])
+;; sorts a list of syntax according to the keywords in the list
 (define-for-syntax (sort-keywords stx kwd/ctc-pairs)
   (define (insert x lst)
     (cond
       [(null? lst) (list x)]
       [else
-       (let ([fst-kwd (syntax-e (car (car lst)))])
-         (printf "comparing ~s to ~s\n" (car x) fst-kwd)
+       (let ([fst-kwd (syntax-e (car (syntax-e (car lst))))]
+             [x-kwd (syntax-e (car (syntax-e x)))])
          (cond
-           [(equal? (syntax-e (car x)) fst-kwd)
+           [(equal? x-kwd fst-kwd)
             (raise-syntax-error #f 
                                 "duplicate keyword"
                                 stx
                                 (car x))]
-           [(keyword<? (syntax-e (car x)) fst-kwd)
+           [(keyword<? x-kwd fst-kwd)
             (cons x lst)]
            [else (cons (car lst) (insert x (cdr lst)))]))]))
   
-  (let loop ([pairs (map syntax->list kwd/ctc-pairs)])
+  (let loop ([pairs kwd/ctc-pairs])
     (cond
       [(null? pairs) null]
       [else (insert (car pairs) (loop (cdr pairs)))])))
@@ -278,19 +311,17 @@ Add both optional and mandatory keywords to opt-> and friends.
                     [use-any? use-any?])
         (with-syntax ([outer-lambda
                        (syntax
-                        (lambda (chk dom-names ... rng-names ... kwd-names ...)
+                        (lambda (chk dom-names ... kwd-names ... rng-names ...)
                           (lambda (val)
                             (chk val)
                             inner-lambda)))])
           (values
-           (syntax (build--> '->
-                             (list dom-ctcs ...)
-                             #f
-                             (list rng-ctcs ...)
-                             (list kwd-ctcs ...)
-                             '(kwds ...)
-                             use-any?
-                             outer-lambda))
+           (syntax 
+            (build--> '->
+                      (list dom-ctcs ...) '() #f
+                      (list kwd-ctcs ...) '(kwds ...) '() '()
+                      (list rng-ctcs ...) use-any?
+                      outer-lambda))
            inner-args/body
            (syntax (dom-names ... rng-names ...))))))))
   
@@ -298,94 +329,118 @@ Add both optional and mandatory keywords to opt-> and friends.
   (let-values ([(stx _1 _2) (->/proc/main stx)])
     stx))
 
-;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names])
+(define unspecified-dom (gensym 'unspecified-keyword))
+
+;; check-duplicate-kwds : syntax (listof syntax[keyword]) -> void
+(define-for-syntax (check-duplicate-kwds stx kwds)
+  (let loop ([kwds kwds])
+    (unless (null? kwds)
+      (when (member (syntax-e (car kwds)) (map syntax-e (cdr kwds)))
+        (raise-syntax-error #f "duplicate keyword" stx (car kwds))))))
+
+;; ->*/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names])
 (define-for-syntax (->*/proc/main stx)
   (syntax-case* stx (->* any) module-or-top-identifier=?
-    [(->* (doms ...) any)
-     (->/proc/main (syntax (-> doms ... any)))]
-    [(->* (doms ...) (rngs ...))
-     (->/proc/main (syntax (-> doms ... (values rngs ...))))]
-    [(->* (raw-doms ...) rst rng)
-     (with-syntax ([((doms ...) ((dom-kwd dom-kwd-ctc) ...)) (split-doms stx '-> #'(raw-doms ...))])
-       (with-syntax ([(dom-kwd-arg ...) (generate-temporaries (syntax (dom-kwd ...)))]
-                     [(dom-kwd-ctc-id ...) (generate-temporaries (syntax (dom-kwd ...)))])
-         (with-syntax ([(keyword-formal-parameters ...) (apply append (map syntax->list (syntax->list #'((dom-kwd dom-kwd-arg) ...))))]
-                       [(args ...) (generate-temporaries (syntax (doms ...)))]
-                       [(dom-ctc ...) (generate-temporaries (syntax (doms ...)))])
-           (with-syntax ([(dom-x ...) (generate-temporaries (syntax (doms ...)))]
-                         [(args ...) (generate-temporaries (syntax (doms ...)))]
-                         [(rst-x) (generate-temporaries (syntax (rst)))]
-                         [(rest-arg) (generate-temporaries (syntax (rst)))])
-             (syntax-case #'rng (any)
-               [(rngs ...)
-                (with-syntax ([(rng-x ...) (generate-temporaries (syntax (rngs ...)))]
-                              [(rng-args ...) (generate-temporaries (syntax (rngs ...)))])
-                  
-                  (let ([inner-args/body 
-                         #`((args ... keyword-formal-parameters ... . rest-arg)
-                            (let-values ([(rng-args ...)
-                                          #,(if (null? (syntax-e #'(dom-kwd ...)))
-                                                #'(apply val (dom-x args) ... (rst-x rest-arg))
-                                                #'(keyword-apply val 
-                                                                 '(dom-kwd ...)
-                                                                 (list (dom-kwd-ctc-id dom-kwd-arg) ...) 
-                                                                 (dom-x args) ...
-                                                                 (rst-x rest-arg)))])
-                              (values (rng-x rng-args) ...)))])
-                    (with-syntax ([inner-lambda (with-syntax ([(args body) inner-args/body])
-                                                  (add-name-prop
-                                                   (syntax-local-infer-name stx)
-                                                   (syntax (lambda args body))))])
-                      (with-syntax ([outer-lambda 
-                                     (syntax
-                                      (lambda (chk dom-x ... rst-x rng-x ... dom-kwd-ctc-id ...)
-                                        (lambda (val)
-                                          (chk val)
-                                          inner-lambda)))])
-                        (values (syntax (build--> '->*
-                                                  (list doms ...)
-                                                  rst
-                                                  (list rngs ...)
-                                                  (list dom-kwd-ctc ...)
-                                                  '(dom-kwd ...)
-                                                  #f 
-                                                  outer-lambda))
-                                inner-args/body
-                                (syntax (dom-x ... rst-x rng-x ...)))))))]
-               [any
-                (let ([inner-args/body 
-                       #`((args ... keyword-formal-parameters ... . rest-arg)
-                          #,(if (null? (syntax-e #'(dom-kwd ...)))
-                                #'(apply val (dom-x args) ... (rst-x rest-arg))
-                                #'(keyword-apply val
-                                                 '(dom-kwd ...) 
-                                                 (list (dom-kwd-ctc-id dom-kwd-arg) ...)
-                                                 (dom-x args) ...
-                                                 (rst-x rest-arg))))])
-                  (with-syntax ([inner-lambda (with-syntax ([(args body) inner-args/body])
-                                                (add-name-prop
-                                                 (syntax-local-infer-name stx)
-                                                 (syntax (lambda args body))))])
-                    (with-syntax ([outer-lambda 
-                                   (syntax
-                                    (lambda (chk dom-x ... rst-x ignored dom-kwd-ctc-id ...)
-                                      (lambda (val)
-                                        (chk val)
-                                        inner-lambda)))])
-                      (values (syntax (build--> '->*
-                                                (list doms ...)
-                                                rst
-                                                (list any/c)
-                                                (list dom-kwd-ctc ...)
-                                                '(dom-kwd ...)
-                                                #t
-                                                outer-lambda))
-                              inner-args/body
-                              (syntax (dom-x ... rst-x))))))])))))]))
-
-(define-syntax (->* stx) 
-  (let-values ([(stx _1 _2) (->*/proc/main stx)])
-    stx))
+    [(->* (raw-mandatory-dom ...) (raw-optional-dom ...) . rst)
+     (with-syntax ([((mandatory-dom ...) ((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...))
+                    (split-doms stx '->* #'(raw-mandatory-dom ...))]
+                   [((optional-dom ...) ((optional-dom-kwd optional-dom-kwd-ctc) ...))
+                    (split-doms stx '->* #'(raw-optional-dom ...))])
+       ;(check-duplicate-kwds stx (syntax->list #'(mandatory-dom-kwd ... optional-dom-kwd ...)))
+       (with-syntax ([(mandatory-dom-proj ...) (generate-temporaries #'(mandatory-dom ...))]
+                     [(mandatory-dom-arg ...) (generate-temporaries #'(mandatory-dom ...))]
+                     [(mandatory-dom-kwd-proj ...) (generate-temporaries #'(mandatory-dom-kwd ...))]
+                     [(mandatory-dom-kwd-arg ...) (generate-temporaries #'(mandatory-dom-kwd ...))]
+                     
+                     [(optional-dom-proj ...) (generate-temporaries #'(optional-dom ...))]
+                     [(optional-dom-arg ...) (generate-temporaries #'(optional-dom ...))]
+                     [(optional-dom-kwd-proj ...) (generate-temporaries #'(optional-dom-kwd ...))]
+                     [(optional-dom-kwd-arg ...) (generate-temporaries #'(optional-dom-kwd ...))])
+         (with-syntax ([(mandatory-dom-kwd/var-seq ...) (apply append 
+                                                               (map list
+                                                                    (syntax->list #'(mandatory-dom-kwd ...)) 
+                                                                    (syntax->list #'(mandatory-dom-kwd-arg ...))))]
+                       [(optional-dom-kwd/var-seq ...) (apply append 
+                                                              (map list 
+                                                                   (syntax->list #'(optional-dom-kwd ...)) 
+                                                                   (syntax->list #'([optional-dom-kwd-arg unspecified-dom] ...))))]
+                       [(mandatory-dom-kwd-proj-apps ...) (apply append 
+                                                                 (map list
+                                                                      (syntax->list #'(mandatory-dom-kwd ...)) 
+                                                                      (syntax->list #'((mandatory-dom-kwd-proj mandatory-dom-kwd-arg) ...))))]
+                       [((sorted-dom-kwd sorted-dom-kwd-arg sorted-dom-kwd-proj) ...) 
+                        (sort-keywords stx (syntax->list
+                                            #'((mandatory-dom-kwd mandatory-dom-kwd-arg mandatory-dom-kwd-proj) ...
+                                               (optional-dom-kwd optional-dom-kwd-arg optional-dom-kwd-proj) ...)))])
+           (with-syntax ([((rev-sorted-dom-kwd rev-sorted-dom-kwd-arg rev-sorted-dom-kwd-proj) ...)
+                          (reverse (syntax->list #'((sorted-dom-kwd sorted-dom-kwd-arg sorted-dom-kwd-proj) ...)))]
+                         [(rev-optional-dom-arg ...) (reverse (syntax->list #'(optional-dom-arg ...)))]
+                         [(rev-optional-dom-proj ...) (reverse (syntax->list #'(optional-dom-proj ...)))])
+             
+             
+             (let-values ([(rest-ctc rng-ctc)
+                           ;; rest-ctc (or/c #f syntax) -- #f means no rest contract, syntax is the contract
+                           ;; rng-ctc (or/c #f syntax) -- #f means `any', syntax is a sequence of result values
+                           (syntax-case #'rst (any)
+                             [(any) (values #f #f)]
+                             [(rest-expr any) (values #'rest-expr #f)]
+                             [((res-ctc ...)) (values #f #'(res-ctc ...))]
+                             [(rest-expr (res-ctc ...)) (values #'rest-expr #'(res-ctc ...))]
+                             [_ (raise-syntax-error #f "bad syntax" stx)])])
+               (with-syntax ([(rng-proj ...) (generate-temporaries (or rng-ctc '()))]
+                             [(rng ...) (generate-temporaries (or rng-ctc '()))])
+                 #`(build-->
+                    '->*
+                    (list mandatory-dom ...)
+                    (list optional-dom ...)
+                    #,rest-ctc
+                    (list mandatory-dom-kwd-ctc ...)
+                    '(mandatory-dom-kwd ...)
+                    (list optional-dom-kwd-ctc ...)
+                    '(optional-dom-kwd ...)
+                    #,(if rng-ctc
+                          (with-syntax ([(rng-ctc ...) rng-ctc])
+                            #'(list rng-ctc ...))
+                          #''())
+                    #,(if rng-ctc #f #t)
+                    (λ (chk mandatory-dom-proj ...  
+                            #,@(if rest-ctc
+                                   #'(rest-proj)
+                                   #'())
+                            optional-dom-proj ... 
+                            mandatory-dom-kwd-proj ... 
+                            optional-dom-kwd-proj ... 
+                            rng-proj ...)
+                      (λ (f)
+                        (chk f)
+                        #,(add-name-prop
+                           (syntax-local-infer-name stx)
+                           #`(λ (mandatory-dom-arg ... 
+                                 [optional-dom-arg unspecified-dom] ... 
+                                 mandatory-dom-kwd/var-seq ... 
+                                 optional-dom-kwd/var-seq ...
+                                 #,@(if rest-ctc #'rest #'()))
+                               (let*-values ([(kwds kwd-args) (values '() '())]
+                                             [(kwds kwd-args) (if (eq? unspecified-dom rev-sorted-dom-kwd-arg)
+                                                                  (values kwds kwd-args)
+                                                                  (values (cons 'rev-sorted-dom-kwd kwds)
+                                                                          (cons (rev-sorted-dom-kwd-proj rev-sorted-dom-kwd-arg)
+                                                                                kwd-args)))] 
+                                             ...
+                                             [(opt-args) #,(if rest-ctc 
+                                                               #'(rest-proj rest)
+                                                               #''())]
+                                             [(opt-args) (if (eq? unspecified-dom rev-optional-dom-arg)
+                                                             opt-args
+                                                             (cons (rev-optional-dom-proj rev-optional-dom-arg) opt-args))]
+                                             ...)
+                                 #,(let ([call #'(keyword-apply f kwds kwd-args (mandatory-dom-proj mandatory-dom-arg) ... opt-args)])
+                                     (if rng-ctc
+                                         #`(let-values ([(rng ...) #,call])
+                                             (values (rng-proj rng) ...))
+                                         call))))))))))))))]))
+           
+(define-syntax (->* stx) (->*/proc/main stx))
 
 (define-for-syntax (select/h stx err-name ctxt-stx)
   (syntax-case stx (-> ->* ->d ->d* ->r ->pp ->pp-rest)
@@ -479,7 +534,7 @@ Add both optional and mandatory keywords to opt-> and friends.
                      (dom-len (length dom-vars))
                      ((next-rng ...) next-rngs))
          (syntax (begin
-                   (check-procedure val dom-len '() #| mandatory-keywords |# src-info pos orig-str)
+                   (check-procedure val dom-len 0 '() '() #| keywords |# src-info pos orig-str)
                    (λ (dom-arg ...)
                      (let-values ([(rng-arg ...) (val next-dom ...)])
                        (values next-rng ...))))))
@@ -527,7 +582,7 @@ Add both optional and mandatory keywords to opt-> and friends.
                      ((next-dom ...) next-doms)
                      (dom-len (length dom-vars)))
          (syntax (begin
-                   (check-procedure val dom-len '() #|mandatory-keywords|# src-info pos orig-str)
+                   (check-procedure val dom-len 0 '() '() #|keywords|# src-info pos orig-str)
                    (λ (dom-arg ...)
                      (val next-dom ...)))))
        lifts-doms
diff --git a/collects/tests/mzscheme/contract-mzlib-test.ss b/collects/tests/mzscheme/contract-mzlib-test.ss
index 05072f0..a0008e5 100644
--- a/collects/tests/mzscheme/contract-mzlib-test.ss
+++ b/collects/tests/mzscheme/contract-mzlib-test.ss
@@ -13,12 +13,11 @@ of the contract library does not change over time.
 (let ()
   
   (define contract-namespace 
-    (let ([n (make-base-namespace)])
+    (let ([n ((dynamic-require 'mzscheme 'make-namespace))])
       (parameterize ([current-namespace n])
-        (namespace-require '(for-syntax mzscheme))
-        (namespace-require '(for-template mzscheme))
         (namespace-require 'mzlib/contract)
         (namespace-require 'mzlib/class)
+        (namespace-require 'mzlib/etc)
         (namespace-require '(only mzscheme force delay)))
       n))
   
@@ -79,12 +78,6 @@ of the contract library does not change over time.
   (define (test/spec-failed name expression blame)
     (let ()
       (define (has-proper-blame? msg)
-        (printf ">> ~s\n"
-                (cond
-                  [(regexp-match #rx"(^| )([^ ]*) broke" msg) 
-                   =>
-                   (λ (x) (caddr x))]
-                  [else (format "no blame in error message: \"~a\"" msg)]))
         (equal?
          blame
          (cond
@@ -96,7 +89,7 @@ of the contract library does not change over time.
       (contract-eval
        `(,thunk-error-test 
           (lambda () ,expression)
-          (datum->syntax #'here ',expression)
+          (datum->syntax-object #'here ',expression)
           (lambda (exn)
             (and (exn? exn)
                  (,has-proper-blame? (exn-message exn))))))
@@ -105,7 +98,7 @@ of the contract library does not change over time.
           (contract-eval
            `(,thunk-error-test 
              (lambda () ,rewritten)
-             (datum->syntax #'here ',rewritten)
+             (datum->syntax-object #'here ',rewritten)
              (lambda (exn)
                (and (exn? exn)
                     (,has-proper-blame? (exn-message exn))))))))))
@@ -1969,7 +1962,7 @@ of the contract library does not change over time.
    '(contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?))))
               (new (class object%
                      (define/public m
-                       (lambda (x [y 'a])
+                       (opt-lambda (x [y 'a])
                          x))
                      (super-new)))
               'pos
@@ -1980,7 +1973,7 @@ of the contract library does not change over time.
    '(contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?))))
               (new (class object%
                      (define/public m
-                       (lambda (x y [z #t])
+                       (opt-lambda (x y [z #t])
                          x))
                      (super-new)))
               'pos
@@ -1991,7 +1984,7 @@ of the contract library does not change over time.
    '(contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?))))
               (new (class object%
                      (define/public m
-                       (lambda (x [y 'a] [z #t])
+                       (opt-lambda (x [y 'a] [z #t])
                          x))
                      (super-new)))
               'pos
@@ -2002,7 +1995,7 @@ of the contract library does not change over time.
    '(send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?))))
                     (new (class object%
                            (define/public m
-                             (lambda (x [y 'a] [z #t])
+                             (opt-lambda (x [y 'a] [z #t])
                                x))
                            (super-new)))
                     'pos
@@ -2016,7 +2009,7 @@ of the contract library does not change over time.
    '(send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?))))
                     (new (class object%
                            (define/public m
-                             (lambda (x [y 'a] [z #t])
+                             (opt-lambda (x [y 'a] [z #t])
                                x))
                            (super-new)))
                     'pos
@@ -2031,7 +2024,7 @@ of the contract library does not change over time.
    '(send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?))))
                     (new (class object%
                            (define/public m
-                             (lambda (x [y 'a] [z #t])
+                             (opt-lambda (x [y 'a] [z #t])
                                x))
                            (super-new)))
                     'pos
@@ -2047,7 +2040,7 @@ of the contract library does not change over time.
    '(send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?))))
                     (new (class object%
                            (define/public m
-                             (lambda (x [y 'a] [z #t])
+                             (opt-lambda (x [y 'a] [z #t])
                                x))
                            (super-new)))
                     'pos
@@ -2060,7 +2053,7 @@ of the contract library does not change over time.
    '(send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?))))
                     (new (class object%
                            (define/public m
-                             (lambda (x [y 'a] [z #t])
+                             (opt-lambda (x [y 'a] [z #t])
                                x))
                            (super-new)))
                     'pos
@@ -2074,7 +2067,7 @@ of the contract library does not change over time.
    '(send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?))))
                     (new (class object%
                            (define/public m
-                             (lambda (x [y 'a] [z #t])
+                             (opt-lambda (x [y 'a] [z #t])
                                x))
                            (super-new)))
                     'pos
@@ -2089,7 +2082,7 @@ of the contract library does not change over time.
    '(send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?))))
                     (new (class object%
                            (define/public m
-                             (lambda (x [y 'a] [z #t])
+                             (opt-lambda (x [y 'a] [z #t])
                                'x))
                            (super-new)))
                     'pos
@@ -2105,7 +2098,7 @@ of the contract library does not change over time.
                   (send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number? symbol?))))
                                   (new (class object%
                                          (define/public m
-                                           (lambda (x [y 'a] [z #t])
+                                           (opt-lambda (x [y 'a] [z #t])
                                              (values 1 'x)))
                                          (super-new)))
                                   'pos
@@ -2122,7 +2115,7 @@ of the contract library does not change over time.
    '(send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number? symbol?))))
                     (new (class object%
                            (define/public m
-                             (lambda (x [y 'a] [z #t])
+                             (opt-lambda (x [y 'a] [z #t])
                                (values 'x 'x)))
                            (super-new)))
                     'pos
@@ -2137,7 +2130,7 @@ of the contract library does not change over time.
    '(send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number? symbol?))))
                     (new (class object%
                            (define/public m
-                             (lambda (x [y 'a] [z #t])
+                             (opt-lambda (x [y 'a] [z #t])
                                (values 1 1)))
                            (super-new)))
                     'pos
@@ -3631,9 +3624,9 @@ of the contract library does not change over time.
   
   (contract-eval '(define-contract-struct node (val obj rank left right) (make-inspector)))
   (contract-eval '(define (compute-rank n)
-                    (cond
-                      [(not n) 0]
-                      [else (node-rank n)])))
+                    (if n 
+                        (node-rank n)
+                        0)))
   
   (contract-eval '(define-opt/c (leftist-heap-greater-than/rank/opt n r)
                     (or/c not
@@ -3783,7 +3776,7 @@ of the contract library does not change over time.
         (cond
           [(not t1) t2]
           [(not t2) t1]
-          [else
+          [#t
            (let ([t1-val (node-val t1)]
                  [t2-val (node-val t2)])
              (cond
@@ -3793,7 +3786,7 @@ of the contract library does not change over time.
                       (node-left t1)
                       (merge (node-right t1)
                              t2))]
-               [else
+               [#t
                 (pick t2-val 
                       (node-obj t2)
                       (node-left t2)
@@ -3806,7 +3799,7 @@ of the contract library does not change over time.
           (cond
             [(>= ra rb)
              (make-node x obj (+ rb 1) a b)]
-            [else
+            [#t
              (make-node x obj (+ ra 1) b a)])))
       (node-val
        (remove-min (ai (make-node 137 'x 1