Add rename-contract, if/c and failure-result/c from unstable/contract.

pkgs/racket-doc/scribblings/reference/contracts.scrbl

@@ -2819,6 +2819,53 @@ currently being checked.
   @history[#:added "6.1.1.5"]
 }
 
+@defproc[(rename-contract [contract contract?]
+                          [name any/c])
+         contract?]{
+  Produces a contract that acts like @racket[contract] but with the name
+  @racket[name].
+
+  The resulting contract is a flat contract if @racket[contract] is a
+  flat contract.
+
+  @history[#:added "6.2.900.15"]
+}
+
+@defproc[(if/c [predicate (-> any/c any/c)]
+               [then-contract contract?]
+               [else-contract contract?])
+         contract?]{
+  Produces a contract that, when applied to a value, first tests the
+  value with @racket[predicate]; if @racket[predicate] returns true, the
+  @racket[then-contract] is applied; otherwise, the
+  @racket[else-contract] is applied. The resulting contract is a flat
+  contract if both @racket[then-contract] and @racket[else-contract] are
+  flat contracts.
+
+  For example, the following contract enforces that if a value is a
+  procedure, it is a thunk; otherwise it can be any (non-procedure)
+  value:
+    @racketblock[(if/c procedure? (-> any) any/c)]
+  Note that the following contract is @bold{not} equivalent:
+    @racketblock[(or/c (-> any) any/c) (code:comment "wrong!")]
+  The last contract is the same as @racket[any/c] because
+  @racket[or/c] tries flat contracts before higher-order contracts.
+
+  @history[#:added "6.2.900.15"]
+}
+
+@defthing[failure-result/c contract?]{
+  A contract that describes the failure result arguments of procedures
+  such as @racket[hash-ref].
+
+  Equivalent to @racket[(if/c procedure? (-> any) any/c)].
+
+  @history[#:added "6.2.900.15"]
+}
+
+
+
+
 @section{@racketmodname[racket/contract/base]}
 
 @defmodule[racket/contract/base]

racket/collects/racket/contract/base.rkt

@@ -68,4 +68,14 @@
  list-contract?
  
  ;; from private/case-arrow.rkt
- case->)
+ case->
+
+ ;; from here (needs `->`, so can't be deeper)
+ failure-result/c)
+
+;; failure-result/c : contract
+;; Describes the optional failure argument passed to hash-ref, for example.
+;; If the argument is a procedure, it must be a thunk, and it is applied. Otherwise
+;; the argument is simply the value to return.
+(define failure-result/c
+  (if/c procedure? (-> any) any/c))

racket/collects/racket/contract/private/misc.rkt

@@ -64,7 +64,10 @@
          blame-add-cdr-context
          raise-not-cons-blame-error
          
-         random-any/c)
+         random-any/c
+
+         rename-contract
+         if/c)
 
 (define-syntax (flat-murec-contract stx)
   (syntax-case stx  ()
@@ -2155,3 +2158,62 @@
  (listof any/c)
  (cons/c any/c any/c)
  (list/c))
+
+;; rename-contract : contract any/c -> contract
+;; If the argument is a flat contract, so is the result.
+(define (rename-contract ctc name)
+  (unless (contract? ctc)
+    (raise-type-error 'rename-contract "contract?" ctc))
+  (let ([ctc (coerce-contract 'rename-contract ctc)])
+    (if (flat-contract? ctc)
+        (flat-named-contract name (flat-contract-predicate ctc))
+        (let* ([make-contract (if (chaperone-contract? ctc) make-chaperone-contract make-contract)])
+          (define (stronger? this other)
+            (contract-stronger? ctc other))
+          (make-contract #:name name
+                         #:projection (contract-projection ctc)
+                         #:first-order (contract-first-order ctc)
+                         #:stronger stronger?
+                         #:list-contract? (list-contract? ctc))))))
+
+;; (if/c predicate then/c else/c) applies then/c to satisfying
+;;   predicate, else/c to those that don't.
+(define (if/c predicate then/c else/c)
+  #|
+  Naive version:
+    (or/c (and/c predicate then/c)
+          (and/c (not/c predicate) else/c))
+  But that applies predicate twice.
+  |#
+  (unless (procedure? predicate)
+    (raise-type-error 'if/c "procedure?" predicate))
+  (unless (contract? then/c)
+    (raise-type-error 'if/c "contract?" then/c))
+  (unless (contract? else/c)
+    (raise-type-error 'if/c "contract?" else/c))
+  (let ([then-ctc (coerce-contract 'if/c then/c)]
+        [else-ctc (coerce-contract 'if/c else/c)])
+    (define name (build-compound-type-name 'if/c predicate then-ctc else-ctc))
+    ;; Special case: if both flat contracts, make a flat contract.
+    (if (and (flat-contract? then-ctc)
+             (flat-contract? else-ctc))
+        ;; flat contract
+        (let ([then-pred (flat-contract-predicate then-ctc)]
+              [else-pred (flat-contract-predicate else-ctc)])
+          (define (pred x)
+            (if (predicate x) (then-pred x) (else-pred x)))
+          (flat-named-contract name pred))
+        ;; ho contract
+        (let ([then-proj (contract-projection then-ctc)]
+              [then-fo (contract-first-order then-ctc)]
+              [else-proj (contract-projection else-ctc)]
+              [else-fo (contract-first-order else-ctc)])
+          (define ((proj blame) x)
+            (if (predicate x)
+                ((then-proj blame) x)
+                ((else-proj blame) x)))
+          (make-contract
+           #:name name
+           #:projection proj
+           #:first-order
+           (lambda (x) (if (predicate x) (then-fo x) (else-fo x))))))))