From 85e489219c7e596d90f780da119fb8bb16b4cb45 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Sat, 13 Sep 2008 22:35:09 +0000
Subject: [PATCH] a bunch more values are now converted into contracts
 automatically

svn: r11729
---
 collects/mzlib/contract.ss                    |   7 +
 collects/mzlib/scribblings/contract.scrbl     |   4 +-
 collects/scheme/contract.ss                   |   7 +-
 collects/scheme/private/contract-guts.ss      | 270 +++++++++++-------
 collects/scheme/private/contract.ss           | 201 +++++--------
 .../guide/contracts-simple-function.scrbl     |  17 ++
 .../scribblings/reference/contracts.scrbl     |  53 +++-
 .../tests/mzscheme/contract-mzlib-test.ss     |   2 +-
 collects/tests/mzscheme/contract-test.ss      |  40 ++-
 9 files changed, 351 insertions(+), 250 deletions(-)

diff --git a/collects/mzlib/contract.ss b/collects/mzlib/contract.ss
index 9f69097e62..bf96a1caf5 100644
--- a/collects/mzlib/contract.ss
+++ b/collects/mzlib/contract.ss
@@ -79,3 +79,10 @@
          flat-prop flat-pred? flat-get
          first-order-prop first-order-get
          (rename-out [or/c union]))
+
+
+;; copied here because not provided by scheme/contract anymore
+(define (flat-contract/predicate? pred)
+  (or (flat-contract? pred)
+      (and (procedure? pred)
+           (procedure-arity-includes? pred 1))))
\ No newline at end of file
diff --git a/collects/mzlib/scribblings/contract.scrbl b/collects/mzlib/scribblings/contract.scrbl
index fd5922d366..07b39c2473 100644
--- a/collects/mzlib/scribblings/contract.scrbl
+++ b/collects/mzlib/scribblings/contract.scrbl
@@ -51,7 +51,6 @@ from @schememodname[scheme/contract]:
  false/c
  flat-contract
  flat-contract-predicate
- flat-contract/predicate?
  flat-contract?
  flat-murec-contract
  flat-named-contract
@@ -81,4 +80,5 @@ from @schememodname[scheme/contract]:
  vector-immutable/c
  vector-immutableof
  vector/c
- vectorof]
+ ]
+@scheme[vectorof]
diff --git a/collects/scheme/contract.ss b/collects/scheme/contract.ss
index ca55dbf472..e4925763a8 100644
--- a/collects/scheme/contract.ss
+++ b/collects/scheme/contract.ss
@@ -61,8 +61,11 @@ differences from v3:
          
          contract-stronger?
          
-         coerce-contract 
-         flat-contract/predicate?
+         coerce-contract/f
+         coerce-contract
+         coerce-contracts
+         coerce-flat-contract
+         coerce-flat-contracts
          
          build-compound-type-name
          raise-contract-error
diff --git a/collects/scheme/private/contract-guts.ss b/collects/scheme/private/contract-guts.ss
index 876e10a1c5..02027df8db 100644
--- a/collects/scheme/private/contract-guts.ss
+++ b/collects/scheme/private/contract-guts.ss
@@ -12,13 +12,18 @@
          exn:fail:contract2-srclocs
                 
          contract-violation->string
-         coerce-contract
          
-         flat-contract/predicate?
+         coerce-contract
+         coerce-contracts
+         coerce-flat-contract
+         coerce-flat-contracts
+         coerce-contract/f
+         
          flat-contract?
          flat-contract
          flat-contract-predicate
          flat-named-contract
+         build-flat-contract
          
          build-compound-type-name
          
@@ -31,7 +36,6 @@
          contract-name
          contract-proc
          make-proj-contract
-         build-flat-contract
          
          contract-stronger?
          
@@ -66,15 +70,11 @@
   (make-struct-type-property 'contract-first-order))
 
 (define (contract-first-order-passes? c v)
-  (cond
-    [(first-order-pred? c) (((first-order-get c) c) v)]
-    [(and (procedure? c)
-          (procedure-arity-includes? c 1))
-     ;; flat contract as a predicate
-     (c v)]
-    [(flat-pred? c) (((flat-get c) c) v)]
-    [else (error 'contract-first-order-passes? 
-                 "expected a contract as first argument, got ~e, other arg ~e" c v)]))
+  (let ([ctc (coerce-contract 'contract-first-order-passes? c)])
+    (cond
+      [(first-order-pred? ctc) (((first-order-get ctc) ctc) v)]
+      [(flat-pred? c) (((flat-get c) c) v)]
+      [else #t])))
 
 (define (proj-get ctc)
   (cond
@@ -90,25 +90,66 @@
         [b-ctc (coerce-contract 'contract-stronger? b)])
     ((stronger-get a-ctc) a-ctc b-ctc)))
 
+;; coerce-flat-contract : symbol any/c -> contract
+(define (coerce-flat-contract name x)
+  (let ([ctc (coerce-contract/f x)])
+    (unless (flat-pred? ctc)
+      (error name 
+             "expected a flat contract or a value that can be coerced into one, got ~e"
+             x))
+    ctc))
 
-;; coerce-contract : id (union contract? procedure-arity-1) -> contract
-;; contract-proc = sym sym stx -> alpha -> alpha
-;; returns the procedure for the contract after extracting it from the
-;; struct. Coerces the argument to a flat contract if it is procedure, but first.
+;; coerce-flat-contacts : symbol (listof any/c) -> (listof flat-contract)
+;; like coerce-contracts, but insists on flat-contracts
+(define (coerce-flat-contracts name xs) 
+  (let loop ([xs xs]
+             [i 1])
+    (cond
+      [(null? xs) '()]
+      [else
+       (let ([fst (coerce-contract/f (car xs))])
+         (unless (flat-pred? fst)
+           (error name 
+                  "expected all of the arguments to be flat contracts, but argument ~a was not, got ~e" 
+                  i
+                  (car xs)))
+         (cons fst (loop (cdr xs) (+ i 1))))])))
+
+;; coerce-contract : symbol any/c -> contract
 (define (coerce-contract name x)
+  (or (coerce-contract/f x)
+      (error name 
+             "expected contract or a value that can be coerced into one, got ~e"
+             x)))
+
+;; coerce-contracts : symbols (listof any) -> (listof contract)
+;; turns all of the arguments in 'xs' into contracts
+;; the error messages assume that the function named by 'name'
+;; got 'xs' as it argument directly
+(define (coerce-contracts name xs) 
+  (let loop ([xs xs]
+             [i 1])
+    (cond
+      [(null? xs) '()]
+      [(coerce-contract/f (car xs)) => (λ (x) (cons x (loop (cdr xs) (+ i 1))))]
+      [else
+       (error name 
+              "expected all of the arguments to be contracts, but argument ~a was not, got ~e" 
+              i
+              (car xs))])))
+
+;; coerce-contract/f : any -> (or/c #f contract?)
+;; returns #f if the argument could not be coerced to a contract
+(define (coerce-contract/f x)
   (cond
     [(contract? x) x]
-    [(and (procedure? x) (procedure-arity-includes? x 1))
-     (flat-contract x)]
-    ;[(symbol? x) (symbol-contract x)]
-    ;[(char? x) (char-contract x)]
-    ;[(boolean? x) (boolean-contract x)]
-    ;[(regexp? x) (regexp-contract x)]
-    ;[(string? x) (string-contract x)]
-    [else
-     (error name 
-            "expected contract or a value that can be coerced into one, got ~e"
-            x)]))
+    [(and (procedure? x) (procedure-arity-includes? x 1)) 
+     (make-predicate-contract (or (object-name x) '???) x)]
+    [(or (symbol? x) (boolean? x) (char? x)) (make-eq-contract x)]
+    [(string? x) (make-equal-contract x)]
+    [(number? x) (make-=-contract x)]
+    [(or (regexp? x) (byte-regexp? x)) (make-regexp/c x)]
+    [else #f]))
 
 (define-values (make-exn:fail:contract2 
                 exn:fail:contract2?
@@ -274,8 +315,7 @@
 (define (double-any-curred-proj2 pos-blame neg-blame src-info orig-str) values)
 
 
-(define-values (make-flat-contract
-                make-proj-contract)
+(define-values (make-proj-contract)
   (let ()
     (define-struct proj-contract (the-name proj first-order-proc)
       #:property proj-prop
@@ -294,56 +334,30 @@
               (proj-contract-proj this)
               (proj-contract-proj that)))))
     
-    (define-struct flat-contract (the-name predicate)
-      #:property proj-prop flat-proj
-      #:property stronger-prop
-      (λ (this that) 
-        (and (flat-contract? that)
-             (procedure-closure-contents-eq? (flat-contract-predicate this)
-                                             (flat-contract-predicate that))))
-      #:property name-prop (λ (ctc) (flat-contract-the-name ctc))
-      #:property flat-prop (λ (ctc) (flat-contract-predicate ctc)))
-    
-    (values make-flat-contract
-            make-proj-contract)))
+    (values make-proj-contract)))
 
 (define (flat-contract-predicate x) 
-  (unless (flat-contract? x)
-    (error 'flat-contract-predicate "expected a flat contract, got ~e" x))
-  ((flat-get x) x))
-(define (flat-contract? x) (flat-pred? x))
+  (let ([ctc (coerce-flat-contract 'flat-contract-predicate x)])
+    ((flat-get ctc) ctc)))
+
+(define (flat-contract? x) 
+  (let ([c (coerce-contract/f x)])
+    (and c
+         (flat-pred? c))))
+
 (define (contract-name ctc)
-  (if (and (procedure? ctc)
-           (procedure-arity-includes? ctc 1))
-      (or (object-name ctc)
-          'unknown)
-      ((name-get ctc) ctc)))
+  (let ([ctc (coerce-contract 'contract-name ctc)])
+    ((name-get ctc) ctc)))
+
 (define (contract? x) (proj-pred? x))
 (define (contract-proc ctc) ((proj-get ctc) ctc))
 
-(define (check-flat-contract predicate)
-  (unless (and (procedure? predicate)
-               (procedure-arity-includes? predicate 1))
-    (error 'flat-contract
-           "expected procedure of arity 1 as argument, given ~e"
-           predicate)))
-(define (flat-contract predicate)
-  (check-flat-contract predicate)
-  (let ([pname (object-name predicate)])
-    (if pname
-        (flat-named-contract pname predicate)
-        (flat-named-contract '??? predicate))))
-(define (check-flat-named-contract predicate)
-  (unless (and (procedure? predicate)
-               (procedure-arity-includes? predicate 1))
-    (error 'flat-named-contract
-           "expected procedure of arity 1 as second argument, given ~e"
-           predicate)))
+(define (check-flat-contract predicate) (coerce-flat-contract 'flat-contract predicate))
+(define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate))
+(define (check-flat-named-contract predicate) (coerce-flat-contract 'flat-named-contract predicate))
 (define (flat-named-contract name predicate)
-  (check-flat-named-contract predicate)
-  (build-flat-contract name predicate))
-
-(define (build-flat-contract name predicate) (make-flat-contract name predicate))
+  (coerce-flat-contract 'flat-named-contract predicate)
+  (make-predicate-contract name predicate))
 
 ;; build-compound-type-name : (union contract symbol) ... -> (-> sexp)
 (define (build-compound-type-name . fs)
@@ -390,37 +404,23 @@
                         this-ctcs
                         that-ctcs))))))
 
-(define (and/c . fs)
-  (for-each
-   (lambda (x) 
-     (unless (or (contract? x)
-                 (and (procedure? x)
-                      (procedure-arity-includes? x 1)))
-       (error 'and/c "expected procedures of arity 1 or <contract>s, given: ~e" x)))
-   fs)
-  (cond
-    [(null? fs) any/c]
-    [(andmap flat-contract/predicate? fs)
-     (let* ([to-predicate
-             (lambda (x)
-               (if (flat-contract? x)
-                   (flat-contract-predicate x)
-                   x))]
-            [contracts (map (lambda (x) (if (contract? x) x (flat-contract x))) fs)]
-            [pred
-             (let loop ([pred (to-predicate (car fs))]
-                        [preds (cdr fs)])
-               (cond
-                 [(null? preds) pred]
-                 [else
-                  (let* ([fst (to-predicate (car preds))])
-                    (loop (let ([and/c-contract? (lambda (x) (and (pred x) (fst x)))])
-                            and/c-contract?)
-                          (cdr preds)))]))])
-       (flat-named-contract (apply build-compound-type-name 'and/c contracts) pred))]
-    [else
-     (let ([contracts (map (lambda (x) (if (contract? x) x (flat-contract x))) fs)])
-       (make-and/c contracts))]))
+(define (and/c . raw-fs)
+  (let ([contracts (coerce-contracts 'and/c raw-fs)])
+    (cond
+      [(null? contracts) any/c]
+      [(andmap flat-contract? contracts)
+       (let* ([pred
+               (let loop ([pred (flat-contract-predicate (car contracts))]
+                          [preds (cdr contracts)])
+                 (cond
+                   [(null? preds) pred]
+                   [else
+                    (let* ([fst (flat-contract-predicate (car preds))])
+                      (loop (let ([and/c-contract? (lambda (x) (and (pred x) (fst x)))])
+                              and/c-contract?)
+                            (cdr preds)))]))])
+         (flat-named-contract (apply build-compound-type-name 'and/c contracts) pred))]
+      [else (make-and/c contracts)])))
 
 (define-struct any/c ()
   #:omit-define-syntaxes
@@ -454,7 +454,63 @@
 
 (define none/c (make-none/c 'none/c))
 
-(define (flat-contract/predicate? pred)
-  (or (flat-contract? pred)
-      (and (procedure? pred)
-           (procedure-arity-includes? pred 1))))
+
+;                                                                                                                 
+;                                                                                                                 
+;                                                                                                                 
+;                                                                                                                 
+;            ;                      ;;;                                       ;                         ;         
+;          ;;;                                                              ;;;                       ;;;         
+;   ;;;;; ;;;;;   ;;;   ;;; ;; ;;;  ;;;   ;;;         ;;;     ;;;   ;;; ;; ;;;;; ;;; ;;;;;;;    ;;;  ;;;;;  ;;;;  
+;  ;;;;;;;;;;;;  ;;;;;  ;;;;;;;;;;; ;;;  ;;;;;       ;;;;;   ;;;;;  ;;;;;;;;;;;; ;;;;;;;;;;;;  ;;;;; ;;;;; ;;; ;; 
+;  ;;  ;;; ;;;  ;;; ;;; ;;; ;;; ;;; ;;; ;;;  ;;     ;;;  ;; ;;; ;;; ;;; ;;; ;;;  ;;;  ;;  ;;; ;;;  ;; ;;;  ;;;    
+;    ;;;;; ;;;  ;;; ;;; ;;; ;;; ;;; ;;; ;;;         ;;;     ;;; ;;; ;;; ;;; ;;;  ;;;    ;;;;; ;;;     ;;;   ;;;;  
+;  ;;; ;;; ;;;  ;;; ;;; ;;; ;;; ;;; ;;; ;;;  ;;     ;;;  ;; ;;; ;;; ;;; ;;; ;;;  ;;;  ;;; ;;; ;;;  ;; ;;;     ;;; 
+;  ;;; ;;; ;;;;  ;;;;;  ;;; ;;; ;;; ;;;  ;;;;;       ;;;;;   ;;;;;  ;;; ;;; ;;;; ;;;  ;;; ;;;  ;;;;;  ;;;; ;; ;;; 
+;   ;;;;;;  ;;;   ;;;   ;;; ;;; ;;; ;;;   ;;;         ;;;     ;;;   ;;; ;;;  ;;; ;;;   ;;;;;;   ;;;    ;;;  ;;;;  
+;                                                                                                                 
+;                                                                                                                 
+;                                                                                                                 
+;                                                                                                                 
+
+(define-struct eq-contract (val)
+  #:property proj-prop flat-proj
+  #:property flat-prop (λ (ctc) (λ (x) (eq? (eq-contract-val ctc) x)))
+  #:property name-prop (λ (ctc) 
+                         (if (symbol? (eq-contract-val ctc))
+                             `',(eq-contract-val ctc)
+                             (eq-contract-val ctc)))
+  #:property stronger-prop (λ (this that) (and (eq-contract? that) (eq? (eq-contract-val this) (eq-contract-val that)))))
+
+(define-struct equal-contract (val)
+  #:property proj-prop flat-proj
+  #:property flat-prop (λ (ctc) (λ (x) (equal? (equal-contract-val ctc) x)))
+  #:property name-prop (λ (ctc) (equal-contract-val ctc))
+  #:property stronger-prop (λ (this that) (and (equal-contract? that) (equal? (equal-contract-val this) (equal-contract-val that)))))
+
+(define-struct =-contract (val)
+  #:property proj-prop flat-proj
+  #:property flat-prop (λ (ctc) (λ (x) (and (number? x) (= (=-contract-val ctc) x))))
+  #:property name-prop (λ (ctc) (=-contract-val ctc))
+  #:property stronger-prop (λ (this that) (and (=-contract? that) (= (=-contract-val this) (=-contract-val that)))))
+
+(define-struct regexp/c (reg)
+  #:property proj-prop flat-proj
+  #:property flat-prop (λ (ctc) (λ (x) (and (or (string? x) (bytes? x))
+                                            (regexp-match (regexp/c-reg ctc) x)
+                                            #t)))
+  #:property name-prop (λ (ctc) (regexp/c-reg ctc))
+  #:property stronger-prop (λ (this that) (and (regexp/c? that) (eq? (regexp/c-reg this) (regexp/c-reg that)))))
+
+
+(define-struct predicate-contract (name pred)
+  #:property proj-prop flat-proj
+  #:property stronger-prop
+  (λ (this that) 
+    (and (predicate-contract? that)
+         (procedure-closure-contents-eq? (predicate-contract-pred this)
+                                         (predicate-contract-pred that))))
+  #:property name-prop (λ (ctc) (predicate-contract-name ctc))
+  #:property flat-prop (λ (ctc) (predicate-contract-pred ctc)))
+
+(define (build-flat-contract name pred) (make-predicate-contract name pred))
\ No newline at end of file
diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss
index 6484671245..95af546c09 100644
--- a/collects/scheme/private/contract.ss
+++ b/collects/scheme/private/contract.ss
@@ -690,15 +690,7 @@ improve method arity mismatch contract violation error messages?
 (define-syntax (verify-contract stx)
   (syntax-case stx ()
     [(_ x) (a:known-good-contract? #'x) #'x]
-    [(_ x) #'(verify-contract/proc x)]))
-
-(define (verify-contract/proc x)
-  (unless (or (contract? x)
-              (and (procedure? x)
-                   (procedure-arity-includes? x 1)))
-    (error 'provide/contract "expected a contract or a procedure of arity one, got ~e" x))
-  x)
-
+    [(_ x) #'(coerce-contract 'provide/contract x)]))
 
 (define (make-pc-struct-type struct-name struct:struct-name . ctcs)
   (let-values ([(struct:struct-name _make _pred _get _set)
@@ -727,19 +719,6 @@ improve method arity mismatch contract violation error messages?
                                                   vals)))))])
     struct:struct-name))
 
-(define (test-proc/flat-contract f x)
-  (if (flat-contract? f)
-      ((flat-contract-predicate f) x)
-      (f x)))
-
-(define (proc/ctc->ctc f)
-  (if (contract? f)
-      f
-      (flat-named-contract
-       (or (object-name f)
-           (string->symbol (format "contract:~e" f)))
-       f)))
-
 (define-syntax (-contract stx)
   (syntax-case stx ()
     [(_ a-contract to-check pos-blame-e neg-blame-e)
@@ -891,53 +870,40 @@ improve method arity mismatch contract violation error messages?
 (define or/c
   (case-lambda 
     [() (make-none/c '(or/c))]
-    [args
-     (for-each
-      (λ (x) 
-        (unless (or (contract? x)
-                    (and (procedure? x)
-                         (procedure-arity-includes? x 1)))
-          (error 'or/c "expected procedures of arity 1 or contracts, given: ~e" x)))
-      args)
-     (let-values ([(ho-contracts fc/predicates)
-                   (let loop ([ho-contracts '()]
-                              [fc/predicates null]
-                              [args args])
-                     (cond
-                       [(null? args) (values ho-contracts (reverse fc/predicates))]
-                       [else 
-                        (let ([arg (car args)])
-                          (cond
-                            [(and (contract? arg)
-                                  (not (flat-contract? arg)))
-                             (loop (cons arg ho-contracts) fc/predicates (cdr args))]
-                            [else
-                             (loop ho-contracts (cons arg fc/predicates) (cdr args))]))]))])
-       (let ([flat-contracts (map (λ (x) (if (flat-contract? x)
-                                             x
-                                             (flat-contract x)))
-                                  fc/predicates)]
-             [pred 
-              (cond
-                [(null? fc/predicates) not]
-                [else
-                 (let loop ([fst (car fc/predicates)]
-                            [rst (cdr fc/predicates)])
-                   (let ([fst-pred (if (flat-contract? fst)
-                                       ((flat-get fst) fst)
-                                       fst)])
-                     (cond
-                       [(null? rst) fst-pred]
-                       [else 
-                        (let ([r (loop (car rst) (cdr rst))])
-                          (λ (x) (or (fst-pred x) (r x))))])))])])
-         (cond
-           [(null? ho-contracts)
-            (make-flat-or/c pred flat-contracts)]
-           [(null? (cdr ho-contracts))
-            (make-or/c pred flat-contracts (car ho-contracts))]
-           [else
-            (make-multi-or/c flat-contracts ho-contracts)])))]))
+    [raw-args
+     (let ([args (coerce-contracts 'or/c raw-args)])
+       (let-values ([(ho-contracts flat-contracts)
+                     (let loop ([ho-contracts '()]
+                                [flat-contracts '()]
+                                [args args])
+                       (cond
+                         [(null? args) (values ho-contracts (reverse flat-contracts))]
+                         [else 
+                          (let ([arg (car args)])
+                            (cond
+                              [(flat-contract? arg)
+                               (loop ho-contracts (cons arg flat-contracts) (cdr args))]
+                              [else
+                               (loop (cons arg ho-contracts) flat-contracts (cdr args))]))]))])
+         (let ([pred 
+                (cond
+                  [(null? flat-contracts) not]
+                  [else
+                   (let loop ([fst (car flat-contracts)]
+                              [rst (cdr flat-contracts)])
+                     (let ([fst-pred (flat-contract-predicate fst)])
+                       (cond
+                         [(null? rst) fst-pred]
+                         [else 
+                          (let ([r (loop (car rst) (cdr rst))])
+                            (λ (x) (or (fst-pred x) (r x))))])))])])
+           (cond
+             [(null? ho-contracts)
+              (make-flat-or/c pred flat-contracts)]
+             [(null? (cdr ho-contracts))
+              (make-or/c pred flat-contracts (car ho-contracts))]
+             [else
+              (make-multi-or/c flat-contracts ho-contracts)]))))]))
 
 (define-struct or/c (pred flat-ctcs ho-ctc)
   #:omit-define-syntaxes
@@ -962,11 +928,11 @@ improve method arity mismatch contract violation error messages?
   
   #:property first-order-prop
   (λ (ctc)
-    (let ([flats (map (λ (x) ((flat-get x) x)) (or/c-flat-ctcs ctc))]
+    (let ([pred (or/c-pred ctc)]
           [ho ((first-order-get (or/c-ho-ctc ctc)) (or/c-ho-ctc ctc))])
       (λ (x)
         (or (ho x)
-            (ormap (λ (f) (f x)) flats)))))
+            (pred x)))))
    
   #:property stronger-prop
   (λ (this that)
@@ -983,8 +949,7 @@ improve method arity mismatch contract violation error messages?
   (let* ([ho-contracts (multi-or/c-ho-ctcs ctc)]
          [c-procs (map (λ (x) ((proj-get x) x)) ho-contracts)]
          [first-order-checks (map (λ (x) ((first-order-get x) x)) ho-contracts)]
-         [predicates (map (λ (x) ((flat-get x) x))
-                          (multi-or/c-flat-ctcs ctc))])
+         [predicates (map flat-contract-predicate (multi-or/c-flat-ctcs ctc))])
     (λ (pos-blame neg-blame src-info orig-str)
       (let ([partial-contracts (map (λ (c-proc) (c-proc pos-blame neg-blame src-info orig-str)) c-procs)])
         (λ (val)
@@ -1033,7 +998,7 @@ improve method arity mismatch contract violation error messages?
   
   #:property first-order-prop
   (λ (ctc)
-    (let ([flats (map (λ (x) ((flat-get x) x)) (multi-or/c-flat-ctcs ctc))]
+    (let ([flats (map flat-contract-predicate (multi-or/c-flat-ctcs ctc))]
           [hos (map (λ (x) ((first-order-get x) x)) (multi-or/c-ho-ctcs ctc))])
       (λ (x)
         (or (ormap (λ (f) (f x)) hos)
@@ -1196,10 +1161,7 @@ improve method arity mismatch contract violation error messages?
     [(or/c p ...)
      (opt/or-ctc (syntax->list (syntax (p ...))))]))
 
-(define false/c
-  (flat-named-contract
-   'false/c
-   (λ (x) (not x))))
+(define false/c #f)
 
 (define (string-len/c n)
   (unless (number? n)
@@ -1527,11 +1489,11 @@ improve method arity mismatch contract violation error messages?
           (<= start x end)))))
 
 (define (not/c f)
-  (unless (flat-contract/predicate? f)
-    (error 'not/c "expected a procedure of arity 1 or <flat-named-contract>, given: ~e" f))
-  (build-flat-contract
-   (build-compound-type-name 'not/c (proc/ctc->ctc f))
-   (λ (x) (not (test-proc/flat-contract f x)))))
+  (let* ([ctc (coerce-flat-contract 'not/c f)]
+         [pred (flat-contract-predicate ctc)])
+    (build-flat-contract
+     (build-compound-type-name 'not/c ctc)
+     (λ (x) (not (pred x))))))
 
 (define-syntax (*-immutableof stx)
   (syntax-case stx ()
@@ -1577,43 +1539,35 @@ improve method arity mismatch contract violation error messages?
                  vector-immutableof))
 
 (define (vectorof p)
-  (unless (flat-contract/predicate? p)
-    (error 'vectorof "expected a flat contract or procedure of arity 1 as argument, got: ~e" p))
-  (build-flat-contract
-   (build-compound-type-name 'vectorof (proc/ctc->ctc p))
-   (λ (v)
-     (and (vector? v)
-          (andmap (λ (ele) (test-proc/flat-contract p ele))
-                  (vector->list v))))))
+  (let* ([ctc (coerce-flat-contract 'vectorof p)]
+         [pred (flat-contract-predicate ctc)])
+    (build-flat-contract
+     (build-compound-type-name 'vectorof ctc)
+     (λ (v)
+       (and (vector? v)
+            (andmap pred (vector->list v)))))))
 
 (define (vector/c . args)
-  (unless (andmap flat-contract/predicate? args)
-    (error 'vector/c "expected flat contracts as arguments, got: ~a"
-           (let loop ([args args])
-             (cond
-               [(null? args) ""]
-               [(null? (cdr args)) (format "~e" (car args))]
-               [else (string-append
-                      (format "~e " (car args))
-                      (loop (cdr args)))]))))
-  (let ([largs (length args)])
+  (let* ([ctcs (coerce-flat-contracts 'vector/c args)]
+         [largs (length args)]
+         [procs (map flat-contract-predicate ctcs)])
     (build-flat-contract
-     (apply build-compound-type-name 'vector/c (map proc/ctc->ctc args))
+     (apply build-compound-type-name 'vector/c ctcs)
      (λ (v)
        (and (vector? v)
             (= (vector-length v) largs)
-            (andmap test-proc/flat-contract
-                    args
+            (andmap (λ (p? x) (p? x))
+                    procs
                     (vector->list v)))))))
 
 (define (box/c pred)
-  (unless (flat-contract/predicate? pred)
-    (error 'box/c "expected a flat contract or a procedure of arity 1, got: ~e" pred))
-  (build-flat-contract
-   (build-compound-type-name 'box/c (proc/ctc->ctc pred))
-   (λ (x)
-     (and (box? x)
-          (test-proc/flat-contract pred (unbox x))))))
+  (let* ([ctc (coerce-flat-contract 'box/c pred)]
+         [p? (flat-contract-predicate ctc)])
+    (build-flat-contract
+     (build-compound-type-name 'box/c ctc)
+     (λ (x)
+       (and (box? x)
+            (p? (unbox x)))))))
 
 ;;
 ;; cons/c opter
@@ -1680,6 +1634,13 @@ improve method arity mismatch contract violation error messages?
     [(cons/c hdp tlp)
      (opt/cons-ctc #'hdp #'tlp)]))
 
+;; only used by the opters
+(define (flat-contract/predicate? pred)
+  (or (flat-contract? pred)
+      (and (procedure? pred)
+           (procedure-arity-includes? pred 1))))
+
+
 (define-syntax (*-immutable/c stx)
   (syntax-case stx ()
     [(_ predicate? constructor (arb? selectors ...) type-name name)
@@ -1708,7 +1669,7 @@ improve method arity mismatch contract violation error messages?
                                ...))))
                      (let ([procs (contract-proc ctc-x)] ...)
                        (make-proj-contract
-                        (build-compound-type-name 'name (proc/ctc->ctc params) ...)
+                        (build-compound-type-name 'name ctc-x ...)
                         (λ (pos-blame neg-blame src-info orig-str)
                           (let ([p-apps (procs pos-blame neg-blame src-info orig-str)] ...)
                             (λ (v)
@@ -1738,7 +1699,7 @@ improve method arity mismatch contract violation error messages?
           (let ([ctcs (map (λ (param) (coerce-contract 'name param)) params)])
             (let ([procs (map contract-proc ctcs)])
               (make-proj-contract
-               (apply build-compound-type-name 'name (map proc/ctc->ctc params))
+               (apply build-compound-type-name 'name ctcs)
                (λ (pos-blame neg-blame src-info orig-str)
                  (let ([p-apps (map (λ (proc) (proc pos-blame neg-blame src-info orig-str)) procs)]
                        [count (length params)])
@@ -1821,19 +1782,7 @@ improve method arity mismatch contract violation error messages?
     [(_ hdp tlp) (opt/cons-ctc #'hdp #'tlp)]))
 
 (define (list/c . args)
-  (unless (andmap (λ (x) (or (contract? x)
-                             (and (procedure? x)
-                                  (procedure-arity-includes? x 1))))
-                  args)
-    (error 'list/c "expected contracts or procedures of arity 1, got: ~a"
-           (let loop ([args args]) 
-             (cond
-               [(null? args) ""]
-               [(null? (cdr args)) (format "~e" (car args))]
-               [else (string-append
-                      (format "~e " (car args))
-                      (loop (cdr args)))]))))
-  (let loop ([args args])
+  (let loop ([args (coerce-contracts 'list/c args)])
     (cond
       [(null? args) (flat-contract null?)]
       [else (cons/c (car args) (loop (cdr args)))])))
diff --git a/collects/scribblings/guide/contracts-simple-function.scrbl b/collects/scribblings/guide/contracts-simple-function.scrbl
index 0588b08f2c..3287200c86 100644
--- a/collects/scribblings/guide/contracts-simple-function.scrbl
+++ b/collects/scribblings/guide/contracts-simple-function.scrbl
@@ -276,6 +276,23 @@ scheme
 ]
 
 
+@ctc-section[#:tag "coercion"]{Contracts coerced from other values}
+
+The contract library treates a number of Scheme values as if they are
+contracts directly. We've already seen one main use of that: predicates. Every
+function that accepts one argument can be treated as a predicate
+and thus used as a contract.
+
+But many other values also play double duty as contracts.
+For example, if your function accepts a number or @scheme[#f],
+@scheme[(or/c number? #f)] sufficies. Similarly, the @scheme[result/c] contract
+could have been written with a @scheme[0] in place of @scheme[zero?].
+
+Even better, if you use a regular expression as a contract, the contract
+accepts strings that match the regular expression. For example, 
+the @scheme[is-decimal-string?] predicate could have been written
+@scheme[#rx"[0-9]*\\.[0-9][0-9][0-9]"].
+
 @ctc-section{Contracts on Higher-order Functions}
 
 Function contracts are not just restricted to having simple
diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl
index 347acf7549..bcc86d7c56 100644
--- a/collects/scribblings/reference/contracts.scrbl
+++ b/collects/scribblings/reference/contracts.scrbl
@@ -14,6 +14,11 @@ expectations of one party are met by another party.  The
 @scheme[provide/contract] form is the primary mechanism for
 associating a contract with a binding.
 
+Note that all of the combinators that accept contracts as arguments
+use @scheme[coerce-contract], meaning that symbols, booleans, strings,
+characters, numbers, regular expressions, and predicates are all
+implicitly converted into contracts.
+
 @note-lib[scheme/contract #:use-sources (scheme/private/contract-ds
                                          scheme/private/contract
                                          scheme/private/contract-guts)]
@@ -33,7 +38,7 @@ Constructs a @tech{flat contract} from @scheme[predicate]. A value
 satisfies the contract if the predicate returns a true value.}
 
 
-@defproc[(flat-named-contract [type-name string?][predicate (any/c . -> . any/c)])
+@defproc[(flat-named-contract [type-name string?][predicate (any/c . -> . any)])
          flat-contract?]{
 
 Like @scheme[flat-contract], but the first argument must be a string
@@ -154,7 +159,7 @@ Returns a flat contract that recognizes strings that have fewer than
 
 @defthing[false/c flat-contract?]{
 
-A flat contract that recognizes @scheme[#f].}
+This is just @scheme[#f]. It is here for backwards compatibility.}
 
 
 @defthing[printable/c flat-contract?]{
@@ -898,18 +903,44 @@ for a contract. The arguments should be either contracts or
 symbols. It wraps parenthesis around its arguments and
 extracts the names from any contracts it is supplied with.}
 
-@defform[(coerce-contract id expr)]{
+@defproc[(coerce-contract [id symbol?] [x any/c]) contract?]{
 
-Evaluates @scheme[expr] and, if the result is a
-contract, just returns it. If the result is a procedure of arity
-one, it converts that into a contract. If the result is neither, it
+If @scheme[x] is a contract, it returns it. If it is a procedure of
+arity one, it converts that into a contract by treating the result as
+a predicate. If it is a symbol, boolean, or character, it makes a
+contract that accepts values that are @scheme[eq?] to @scheme[x]. If
+@scheme[x] is a string, it makes a contract that accespts values that
+are @scheme[equal?] to @scheme[x]. If @scheme[x] is a regular
+expression or a byte regular expression, it makes a contract that
+accepts strings and bytes, as long as they match the regular
+expression.
+
+If @scheme[x] is none of the above, @scheme[coerce-contract]
 signals an error, using the first argument in the error
-message. The message says that a contract or a procedure of
-arity one was expected.}
+message.}
 
-@defproc[(flat-contract/predicate? [val any/c]) boolean?]{
+@defproc[(coerce-contracts [id symbol?] [xs (listof any/c)]) (listof contract?)]{
 
-A predicate that indicates when @scheme[coerce-contract] will fail.}
+Coerces all of the arguments in 'xs' into contracts (via
+@scheme[coerce-contract/f]) and signals an error if any of them are not
+contracts.  The error messages assume that the function named by
+@scheme[id] got @scheme[xs] as its entire argument list.
+}
+
+@defproc[(coerce-flat-contract [id symbol?] [x any/c]) flat-contract?]{
+  Like @scheme[coerce-contract], but requires the result
+  to be a flat contract, not an arbitrary contract.
+}
+
+@defproc[(coerce-flat-contracts [id symbol?] [x (listof any/c)]) (listof/c flat-contract?)]{
+  Like @scheme[coerce-contracts], but requires the results
+  to be flat contracts, not arbitrary contracts.
+}
+
+@defproc[(coerce-contract/f [x any/c]) (or/c contract? #f)]{
+  Like @scheme[coerce-contract], but returns @scheme[#f] if
+  the value cannot be coerced to a contract.
+}
 
 @defproc[(raise-contract-error [val any/c]
                                [src-info any/c]
@@ -987,7 +1018,7 @@ name @scheme[sexp-name] when signaling a contract violation.}
 
 @defparam[contract-violation->string 
           proc 
-          (-> any/c any/c (or/c false/c any/c) any/c string? string?)]{
+          (-> any/c any/c (or/c #f any/c) any/c string? string?)]{
 
 This is a parameter that is used when constructing a
 contract violation error. Its value is procedure that
diff --git a/collects/tests/mzscheme/contract-mzlib-test.ss b/collects/tests/mzscheme/contract-mzlib-test.ss
index c32dc4c0af..4d0b8c923d 100644
--- a/collects/tests/mzscheme/contract-mzlib-test.ss
+++ b/collects/tests/mzscheme/contract-mzlib-test.ss
@@ -4162,7 +4162,7 @@ so that propagation occurs.
   (test-name '(real-in 1 10) (real-in 1 10))
   (test-name '(string-len/c 3) (string/len 3))
   (test-name 'natural-number/c natural-number/c)
-  (test-name 'false/c false/c)
+  (test-name #f false/c)
   (test-name 'printable/c printable/c)
   (test-name '(symbols 'a 'b 'c) (symbols 'a 'b 'c))
   (test-name '(one-of/c 1 2 3) (one-of/c 1 2 3))
diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss
index 65ef9dfd1c..1177d516b9 100644
--- a/collects/tests/mzscheme/contract-test.ss
+++ b/collects/tests/mzscheme/contract-test.ss
@@ -188,7 +188,10 @@
   
   (test/no-error '(listof any/c))
   (test/no-error '(listof (lambda (x) #t)))
+
   
+  (test/no-error '(list/c 'x "x" #t #f #\c #rx"a" #rx#"b"))
+
   
 
 ;                                                                                      
@@ -4522,6 +4525,22 @@ so that propagation occurs.
   (test-flat-contract '(string-len/c 3) "ab" "abc")
   (test-flat-contract 'natural-number/c 5 -1)
   (test-flat-contract 'false/c #f #t)
+  
+  (test-flat-contract #t #t "x")
+  (test-flat-contract #f #f "x")
+  (test-flat-contract #\a #\a #\b)
+  (test-flat-contract #\a #\a 'a)
+  (test-flat-contract ''a 'a 'b)
+  (test-flat-contract ''a 'a #\a)
+  (test-flat-contract "x" "x" "y")
+  (test-flat-contract "x" "x" 'x)
+  (test-flat-contract 1 1 2)
+  (test-flat-contract #e1 #i1.0 'x)
+  (test-flat-contract #rx".x." "axq" "x")
+  (test-flat-contract #rx#".x." #"axq" #"x")
+  (test-flat-contract #rx".x." #"axq" #"x")
+  (test-flat-contract #rx#".x." "axq" "x")
+  
   (test/spec-passed 'any/c '(contract any/c 1 'pos 'neg))
   (test-flat-contract 'printable/c (vector (cons 1 (box #f))) (lambda (x) x))
   (let ()
@@ -4589,6 +4608,10 @@ so that propagation occurs.
         (with-handlers ((exn? exn:fail:syntax?)) 
           (contract-eval '(flat-murec-contract ([x y])))
           'no-err))
+  
+  ;; test flat-contract-predicate
+  (test #t (flat-contract-predicate integer?) 1)
+  (test #t (flat-contract-predicate #t) #t)
 
 
 ;                                                                                                               
@@ -4739,13 +4762,22 @@ so that propagation occurs.
   (test-name '(real-in 1 10) (real-in 1 10))
   (test-name '(string-len/c 3) (string-len/c 3))
   (test-name 'natural-number/c natural-number/c)
-  (test-name 'false/c false/c)
+  (test-name #f false/c)
+  (test-name #t #t)
+  (test-name #\a #\a)
+  (test-name "x" "x")
+  (test-name ''x 'x)
+  ;(test-name #rx"x" #rx"x")  ;; commented out because regexps don't compare via equal?
+  ;(test-name #rx#"x" #rx#"x") ;; commented out because regexps don't compare via equal?
   (test-name 'printable/c printable/c)
   (test-name '(symbols 'a 'b 'c) (symbols 'a 'b 'c))
   (test-name '(one-of/c 1 2 3) (one-of/c 1 2 3))
   (test-name '(one-of/c '() 'x 1 #f #\a (void) (letrec ([x x]) x)) 
              (one-of/c '() 'x 1 #f #\a (void) (letrec ([x x]) x)))
   
+  (test-name '(or/c #f #t #\a "x") (or/c #f #t #\a "x"))
+  ;(test-name '(or/c #f #t #\a "x" #rx"x" #rx#"x") (or/c #f #t #\a "x" #rx"x" #rx#"x")) ;; commented out because regexps don't compare via equal?
+
   (test-name '(subclass?/c class:c%) 
              (let ([c% (class object% (super-new))]) (subclass?/c c%)))
   
@@ -5134,6 +5166,12 @@ so that propagation occurs.
           (with-continuation-mark 'x 'x
             (f 1))))
 
+  (ctest #t contract-first-order-passes? (or/c 'x "x" #rx"x") 'x)
+  (ctest #t contract-first-order-passes? (or/c 'x "x" #rx"x") "x")
+  (ctest #t contract-first-order-passes? (or/c 'x "x" #rx"x.") "xy")
+  (ctest #f contract-first-order-passes? (or/c 'x "x" #rx"x.") "yx")
+  (ctest #f contract-first-order-passes? (or/c 'x "x" #rx"x.") 'y)
+  
 ;                                                                
 ;                                                                
 ;