made the optional arguments clause itself optional for ->*

collects/racket/contract/private/arrow.rkt

@@ -239,8 +239,12 @@ v4 todo:
         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))))
+        (append (let ([opts
-        (append (if doms-rest
+                       (apply build-compound-type-name (append optional-doms/c (apply append (map list optional-kwds optional-kwds/c))))])
+                  (if (null? opts)
+                      '()
+                      (list opts)))
+                (if doms-rest
                     (list '#:rest doms-rest)
                     (list))
                 (if pre 
@@ -537,7 +541,20 @@ v4 todo:
         (raise-syntax-error #f "duplicate keyword" stx (car kwds))))))
 
 (define-for-syntax (parse-leftover->* stx leftover)
-  (let*-values ([(rst leftover)
+  (let*-values ([(raw-optional-doms leftover)
+                 (syntax-case leftover ()
+                   [(kwd . rst)
+                    (keyword? (syntax-e #'kwd))
+                    (values #'() leftover)]
+                   [(rng #:post . rst)
+                    (values #'() leftover)]
+                   [(rng)
+                    (values #'() leftover)]
+                   [((raw-optional-dom ...) . leftover)
+                    (values #'(raw-optional-dom ...) #'leftover)]
+                   [_ 
+                    (values #'() leftover)])]
+                [(rst leftover)
                  (syntax-case leftover ()
                    [(#:rest rest-expr . leftover)
                     (values #'rest-expr #'leftover)]
@@ -567,17 +584,21 @@ v4 todo:
                    [else
                     (values #f leftover)])])
     (syntax-case leftover ()
-      [() (values rst pre rng post)]
+      [() (values raw-optional-doms rst pre rng post)]
       [x (raise-syntax-error #f "expected the end of the contract" stx #'x)])))
 
 ;; ->*/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=?
-    [(->* (raw-mandatory-dom ...) (raw-optional-dom ...) . rst)
+    [(->* (raw-mandatory-dom ...) . rst)
+     (let-values ([(raw-optional-doms rest-ctc pre rng-ctc post)
+                   ;; 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
+                   (parse-leftover->* stx #'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 ...))])
+                      (split-doms stx '->* raw-optional-doms)])
          ;(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 ...))]
@@ -610,10 +631,6 @@ v4 todo:
                            [(rev-optional-dom-proj ...) (reverse (syntax->list #'(optional-dom-proj ...)))])
                
                
-             (let-values ([(rest-ctc pre rng-ctc post)
-                           ;; 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
-                           (parse-leftover->* stx #'rst)])
                (with-syntax ([(rng-proj ...) (generate-temporaries (or rng-ctc '()))]
                              [(rng ...) (generate-temporaries (or rng-ctc '()))]
                              [(this-parameter ...)

collects/tests/racket/contract-test.rktl

@@ -779,6 +779,26 @@
 			   'pos
 			   'neg)))
 
+   (test/spec-passed
+   '->*-opt-optional1
+   '((contract (->* () integer?) (lambda () 1) 'pos 'neg)))
+
+   (test/spec-passed
+   '->*-opt-optional2
+   '((contract (->* () (values boolean? integer?)) (lambda () (values #t 1)) 'pos 'neg)))
+
+   (test/spec-passed
+   '->*-opt-optional3
+   '((contract (->* () #:rest any/c integer?) (lambda x 1) 'pos 'neg)))
+
+   (test/spec-passed
+   '->*-opt-optional4
+   '((contract (->* () #:pre #t integer?) (lambda x 1) 'pos 'neg)))
+
+   (test/spec-passed
+   '->*-opt-optional5
+   '((contract (->* () integer? #:post #t) (lambda x 1) 'pos 'neg)))
+  
 ;               
 ;               
 ;               
@@ -8647,11 +8667,11 @@ so that propagation occurs.
   (test-name '(->* (integer? char? #:z string?) (boolean? #:i number?) #:rest (listof integer?) (values number? boolean? symbol?)) 
               (->* (#:z string? integer? char?) (boolean? #:i number?) #:rest (listof integer?) (values number? boolean? symbol?)))
   
-  (test-name '(->* (integer?) () #:pre ... integer?)
+  (test-name '(->* (integer?) #:pre ... integer?)
 			  (->* (integer?) () #:pre (= 1 2) integer?))
-  (test-name '(->* (integer?) () integer? #:post ...)
+  (test-name '(->* (integer?) integer? #:post ...)
 		 	  (->* (integer?) () integer? #:post #f))
-  (test-name '(->* (integer?) () #:pre ... integer? #:post ...)
+  (test-name '(->* (integer?) #:pre ... integer? #:post ...)
 			  (->* (integer?) () #:pre (= 1 2) integer? #:post #f))
   
   (test-name '(->d () () any) (->d () () any))